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 / krunch.adb < prev    next >
Text File  |  1996-09-28  |  7KB  |  198 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                               K R U N C H                                --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.10 $                              --
  10. --                                                                          --
  11. --        Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved        --
  12. --                                                                          --
  13. -- The GNAT library is free software; you can redistribute it and/or modify --
  14. -- it under terms of the GNU Library General Public License as published by --
  15. -- the Free Software  Foundation; either version 2, or (at your option) any --
  16. -- later version.  The GNAT library is distributed in the hope that it will --
  17. -- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
  18. -- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
  19. -- Library  General  Public  License for  more  details.  You  should  have --
  20. -- received  a copy of the GNU  Library  General Public License  along with --
  21. -- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
  22. -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. procedure Krunch
  27.   (Buffer    : in out String;
  28.    Len       : in out Natural;
  29.    Maxlen    : Natural;
  30.    No_Predef : Boolean)
  31.  
  32. is
  33.    Curlen   : Natural;
  34.    Krlen    : Natural;
  35.    Num_Seps : Natural;
  36.    Startloc : Natural;
  37.  
  38. begin
  39.    --  Deal with special predefined children cases. Startloc is the first
  40.    --  location for the krunch, set to 1, except for the predefined children
  41.    --  case, where it is set to 3, to start after the standard prefix.
  42.  
  43.    if No_Predef then
  44.       Startloc := 1;
  45.       Curlen := Len;
  46.       Krlen := Maxlen;
  47.  
  48.    elsif Len >= 26
  49.      and then Buffer (1 .. 25) = "ada-text_io-wide_text_io-"
  50.    then
  51.       Startloc := 3;
  52.       Buffer (2 .. 5) := "-wt-";
  53.       Buffer (6 .. Len - 20) := Buffer (26 .. Len);
  54.       Curlen := Len - 20;
  55.       Krlen  := 8;
  56.  
  57.    elsif Len >= 4 and then Buffer (1 .. 4) = "ada-" then
  58.       Startloc := 3;
  59.       Buffer (2 .. Len - 2) := Buffer (4 .. Len);
  60.       Curlen := Len - 2;
  61.       Krlen  := 8;
  62.  
  63.    elsif Len >= 5 and then Buffer (1 .. 5) = "gnat-" then
  64.       Startloc := 3;
  65.       Buffer (2 .. Len - 3) := Buffer (5 .. Len);
  66.       Curlen := Len - 3;
  67.       Krlen  := 8;
  68.  
  69.    elsif Len >= 7 and then Buffer (1 .. 7) = "system-" then
  70.       Startloc := 3;
  71.       Buffer (2 .. Len - 5) := Buffer (7 .. Len);
  72.       Curlen := Len - 5;
  73.       Krlen  := 8;
  74.  
  75.    elsif Len >= 11 and then Buffer (1 .. 11) = "interfaces-" then
  76.       Startloc := 3;
  77.       Buffer (2 .. Len - 9) := Buffer (11 .. Len);
  78.       Curlen := Len - 9;
  79.       Krlen  := 8;
  80.  
  81.    --  For the renamings in the obsolescent section, we also force krunching
  82.    --  to 8 characters, but no other special processing is required here.
  83.    --  Note that text_io and calendar are already short enough anyway.
  84.  
  85.    elsif     (Len =  9 and then Buffer (1 ..  9) = "direct_io")
  86.      or else (Len = 10 and then Buffer (1 .. 10) = "interfaces")
  87.      or else (Len = 13 and then Buffer (1 .. 13) = "io_exceptions")
  88.      or else (Len = 12 and then Buffer (1 .. 12) = "machine_code")
  89.      or else (Len = 13 and then Buffer (1 .. 13) = "sequential_io")
  90.      or else (Len = 20 and then Buffer (1 .. 20) = "unchecked_conversion")
  91.      or else (Len = 22 and then Buffer (1 .. 22) = "unchecked_deallocation")
  92.    then
  93.       Startloc := 1;
  94.       Krlen    := 8;
  95.       Curlen   := Len;
  96.  
  97.    --  Special case of a child unit whose parent unit is a single letter. In
  98.    --  order to prevent confusion with krunched names of predefined units use
  99.    --  a plus rather than a minus as the second character of the file name.
  100.  
  101.    elsif Len > 1 and then Buffer (2) = '-' and then Len <= Maxlen then
  102.       Buffer (2) := '+';
  103.       return;
  104.  
  105.    --  Normal case, not a predefined file
  106.  
  107.    else
  108.       Startloc := 1;
  109.       Curlen   := Len;
  110.       Krlen    := Maxlen;
  111.    end if;
  112.  
  113.    --  Immediate return if file name is short enough now
  114.  
  115.    if Curlen <= Krlen then
  116.       Len := Curlen;
  117.       return;
  118.    end if;
  119.  
  120.    --  For now, refuse to krunch a name that contains an ESC character (wide
  121.    --  character sequence) since it's too much trouble to do this right ???
  122.  
  123.    for J in 1 .. Curlen loop
  124.       if Buffer (J) = Ascii.ESC then
  125.          return;
  126.       end if;
  127.    end loop;
  128.  
  129.    --  Count number of separators (minus signs and underscores) and for now
  130.    --  replace them by spaces. We keep them around till the end to control
  131.    --  the krunching process, and then we eliminate them as the last step
  132.  
  133.    Num_Seps := 0;
  134.  
  135.    for J in Startloc .. Curlen loop
  136.       if Buffer (J) = '-' or else Buffer (J) = '_' then
  137.          Buffer (J) := ' ';
  138.          Num_Seps := Num_Seps + 1;
  139.       end if;
  140.    end loop;
  141.  
  142.    --  Now we do the one character at a time krunch till we are short enough
  143.  
  144.    while Curlen - Num_Seps > Krlen loop
  145.       declare
  146.          Long_Length : Natural := 0;
  147.          Long_Last   : Natural := 0;
  148.          Piece_Start : Natural;
  149.          Ptr         : Natural;
  150.  
  151.       begin
  152.          Ptr := Startloc;
  153.  
  154.          --  Loop through pieces to find longest piece
  155.  
  156.          while Ptr <= Curlen loop
  157.             Piece_Start := Ptr;
  158.  
  159.             --  Loop through characters in one piece of name
  160.  
  161.             while Ptr <= Curlen and then Buffer (Ptr) /= ' ' loop
  162.                Ptr := Ptr + 1;
  163.             end loop;
  164.  
  165.             if Ptr - Piece_Start > Long_Length then
  166.                Long_Length := Ptr - Piece_Start;
  167.                Long_Last := Ptr - 1;
  168.             end if;
  169.  
  170.             Ptr := Ptr + 1;
  171.          end loop;
  172.  
  173.          --  Remove last character of longest piece
  174.  
  175.          if Long_Last < Curlen then
  176.             Buffer (Long_Last .. Curlen - 1) :=
  177.               Buffer (Long_Last + 1 .. Curlen);
  178.          end if;
  179.  
  180.          Curlen := Curlen - 1;
  181.       end;
  182.    end loop;
  183.  
  184.    --  Final step, remove the spaces
  185.  
  186.    Len := 0;
  187.  
  188.    for J in 1 .. Curlen loop
  189.       if Buffer (J) /= ' ' then
  190.          Len := Len + 1;
  191.          Buffer (Len) := Buffer (J);
  192.       end if;
  193.    end loop;
  194.  
  195.    return;
  196.  
  197. end Krunch;
  198.