| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- K R U N C H -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- 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/>. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| 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 >= 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; |
| Krlen := 8; |
| |
| elsif Len >= 11 and then Buffer (1 .. 11) = "interfaces-" then |
| Startloc := 3; |
| Buffer (2 .. Len - 9) := Buffer (11 .. Len); |
| Curlen := Len - 9; |
| Krlen := 8; |
| |
| -- 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; |
