------------------------------------------------------------------------------ -- 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 -- -- . -- -- -- ------------------------------------------------------------------------------ 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;