------------------------------------------------------------------------------
--                             G N A T C O L L                              --
--                                                                          --
--                        Copyright (C) 2015-2021, AdaCore                  --
--                                                                          --
-- This library is free software;  you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software  Foundation;  either version 3,  or (at your  option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.                            --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
------------------------------------------------------------------------------

package body GNATCOLL.Projects.Krunch is

   ------------
   -- Krunch --
   ------------

   pragma Style_Checks ("M100");
   --  Allow long lines to not reorganize code/comments, this should allow
   --  easier check of krunch being up to date with gnat version.

   procedure Krunch
     (Buffer        : in out String;
      Len           : in out Natural;
      Maxlen        : Natural;
      No_Predef     : Boolean)
   is
      pragma Assert (Buffer'First = 1);
      --  This is a documented requirement; the assert turns off index warnings

      B1       : Character renames Buffer (1);
      Curlen   : Natural;
      Krlen    : Natural;
      Num_Seps : Natural;
      Startloc : Natural;
      J        : Natural;

   begin
      --  Deal with special predefined children cases. Startloc is the first
      --  location for the krunch, set to 1, except for the predefined children
      --  case, where it is set to 3, to start after the standard prefix.

      if No_Predef then
         Startloc := 1;
         Curlen := Len;
         Krlen := Maxlen;

      elsif Len >= 18
        and then Buffer (1 .. 17) = "ada-wide_text_io-"
      then
         Startloc := 3;
         Buffer (2 .. 5) := "-wt-";
         Buffer (6 .. Len - 12) := Buffer (18 .. Len);
         Curlen := Len - 12;
         Krlen  := 8;

      elsif Len >= 23
        and then Buffer (1 .. 22) = "ada-wide_wide_text_io-"
      then
         Startloc := 3;
         Buffer (2 .. 5) := "-zt-";
         Buffer (6 .. Len - 17) := Buffer (23 .. Len);
         Curlen := Len - 17;
         Krlen := 8;

      elsif Len >= 27
        and then Buffer (1 .. 27) = "ada-long_long_long_integer_"
      then
         Startloc := 3;
         Buffer (2 .. Len - 2) := Buffer (4 .. Len);
         Buffer (18 .. Len - 10) := Buffer (26 .. Len - 2);
         Curlen := Len - 10;
         Krlen := 8;

      elsif Len >= 4 and then Buffer (1 .. 4) = "ada-" then
         Startloc := 3;
         Buffer (2 .. Len - 2) := Buffer (4 .. Len);
         Curlen := Len - 2;
         Krlen  := 8;

      elsif Len >= 5 and then Buffer (1 .. 5) = "gnat-" then
         Startloc := 3;
         Buffer (2 .. Len - 3) := Buffer (5 .. Len);
         Curlen := Len - 3;
         Krlen  := 8;

      elsif Len >= 7 and then Buffer (1 .. 7) = "system-" then
         Startloc := 3;
         Buffer (2 .. Len - 5) := Buffer (7 .. Len);
         Curlen := Len - 5;
         if (Curlen >= 3 and then Buffer (Curlen - 2 .. Curlen) = "128")
           or else (Len >= 9 and then
                       (Buffer (3 .. 9) = "exn_lll"
                         or else Buffer (3 .. 9) = "exp_lll"
                         or else Buffer (3 .. 9) = "img_lll"
                         or else Buffer (3 .. 9) = "val_lll"
                         or else Buffer (3 .. 9) = "wid_lll"))
           or else (Curlen = 10 and then Buffer (3 .. 6) = "pack")
         then
            if Len >= 15 and then Buffer (3 .. 15) = "compare_array" then
               Buffer (3 .. 4) := "ca";
               Buffer (5 .. Curlen - 11) := Buffer (16 .. Curlen);
               Curlen := Curlen - 11;
            end if;
            Krlen := 9;
         else
            Krlen := 8;
         end if;

      elsif Len >= 11 and then Buffer (1 .. 11) = "interfaces-" then
         Startloc := 3;
         Buffer (2 .. Len - 9) := Buffer (11 .. Len);
         Curlen := Len - 9;

         --  Only fully krunch historical units. For new units, simply use
         --  the 'i-' prefix instead of 'interfaces-'. Packages Interfaces.C
         --  and Interfaces.Cobol are already in the right form. Package
         --  Interfaces.Definitions is krunched for backward compatibility.

         if        (Curlen >  3 and then Buffer (3 ..  4) = "c-")
           or else (Curlen >  3 and then Buffer (3 ..  4) = "c_")
           or else (Curlen = 13 and then Buffer (3 .. 13) = "definitions")
           or else (Curlen =  9 and then Buffer (3 ..  9) = "fortran")
           or else (Curlen = 16 and then Buffer (3 .. 16) = "packed_decimal")
           or else (Curlen >  8 and then Buffer (3 ..  9) = "vxworks")
           or else (Curlen >  5 and then Buffer (3 ..  6) = "java")
         then
            Krlen := 8;
         else
            Krlen := Maxlen;
         end if;

         --  For the renamings in the obsolescent section, we also force krunching
         --  to 8 characters, but no other special processing is required here.
         --  Note that text_io and calendar are already short enough anyway.

      elsif     (Len =  9 and then Buffer (1 ..  9) = "direct_io")
        or else (Len = 10 and then Buffer (1 .. 10) = "interfaces")
        or else (Len = 13 and then Buffer (1 .. 13) = "io_exceptions")
        or else (Len = 12 and then Buffer (1 .. 12) = "machine_code")
        or else (Len = 13 and then Buffer (1 .. 13) = "sequential_io")
        or else (Len = 20 and then Buffer (1 .. 20) = "unchecked_conversion")
        or else (Len = 22 and then Buffer (1 .. 22) = "unchecked_deallocation")
      then
         Startloc := 1;
         Krlen    := 8;
         Curlen   := Len;

         --  Special case of a child unit whose parent unit is a single letter that
         --  is A, G, I, or S. In order to prevent confusion with krunched names
         --  of predefined units use a tilde rather than a minus as the second
         --  character of the file name.

      elsif Len > 1
        and then Buffer (2) = '-'
        and then (B1 = 'a' or else B1 = 'g' or else B1 = 'i' or else B1 = 's')
        and then Len <= Maxlen
      then
         Buffer (2) := '~';
         return;

         --  Normal case, not a predefined file

      else
         Startloc := 1;
         Curlen   := Len;
         Krlen    := Maxlen;
      end if;

      --  Immediate return if file name is short enough now

      if Curlen <= Krlen then
         Len := Curlen;
         return;
      end if;

      --  If string contains Wide_Wide, replace by a single z

      J := Startloc;
      while J <= Curlen - 8 loop
         if Buffer (J .. J + 8) = "wide_wide"
           and then (J = Startloc
                      or else Buffer (J - 1) = '-'
                      or else Buffer (J - 1) = '_')
           and then (J + 8 = Curlen
                      or else Buffer (J + 9) = '-'
                      or else Buffer (J + 9) = '_')
         then
            Buffer (J) := 'z';
            Buffer (J + 1 .. Curlen - 8) := Buffer (J + 9 .. Curlen);
            Curlen := Curlen - 8;
         end if;

         J := J + 1;
      end loop;

      --  For now, refuse to krunch a name that contains an ESC character (wide
      --  character sequence) since it's too much trouble to do this right ???

      for J in 1 .. Curlen loop
         if Buffer (J) = ASCII.ESC then
            return;
         end if;
      end loop;

      --  Count number of separators (minus signs and underscores) and for now
      --  replace them by spaces. We keep them around till the end to control
      --  the krunching process, and then we eliminate them as the last step

      Num_Seps := 0;
      for J in Startloc .. Curlen loop
         if Buffer (J) = '-' or else Buffer (J) = '_' then
            Buffer (J) := ' ';
            Num_Seps := Num_Seps + 1;
         end if;
      end loop;

      --  Now we do the one character at a time krunch till we are short enough

      while Curlen - Num_Seps > Krlen loop
         declare
            Long_Length : Natural := 0;
            Long_Last   : Natural := 0;
            Piece_Start : Natural;
            Ptr         : Natural;

         begin
            Ptr := Startloc;

            --  Loop through pieces to find longest piece

            while Ptr <= Curlen loop
               Piece_Start := Ptr;

               --  Loop through characters in one piece of name

               while Ptr <= Curlen and then Buffer (Ptr) /= ' ' loop
                  Ptr := Ptr + 1;
               end loop;

               if Ptr - Piece_Start > Long_Length then
                  Long_Length := Ptr - Piece_Start;
                  Long_Last := Ptr - 1;
               end if;

               Ptr := Ptr + 1;
            end loop;

            --  Remove last character of longest piece

            if Long_Last < Curlen then
               Buffer (Long_Last .. Curlen - 1) :=
                 Buffer (Long_Last + 1 .. Curlen);
            end if;

            Curlen := Curlen - 1;
         end;
      end loop;

      --  Final step, remove the spaces

      Len := 0;

      for J in 1 .. Curlen loop
         if Buffer (J) /= ' ' then
            Len := Len + 1;
            Buffer (Len) := Buffer (J);
         end if;
      end loop;

      return;
   end Krunch;

end GNATCOLL.Projects.Krunch;
