diff options
Diffstat (limited to 'gcc/ada/krunch.adb')
| -rw-r--r-- | gcc/ada/krunch.adb | 220 |
1 files changed, 220 insertions, 0 deletions
diff --git a/gcc/ada/krunch.adb b/gcc/ada/krunch.adb new file mode 100644 index 00000000000..3f160e6fd4d --- /dev/null +++ b/gcc/ada/krunch.adb @@ -0,0 +1,220 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- K R U N C H -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.16 $ +-- -- +-- Copyright (C) 1992-2000 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Hostparm; +procedure Krunch + (Buffer : in out String; + Len : in out Natural; + Maxlen : Natural; + No_Predef : Boolean) + +is + B1 : Character renames Buffer (1); + Curlen : Natural; + Krlen : Natural; + Num_Seps : Natural; + Startloc : 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 >= 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. On VMS a tilde is an illegal character + -- in a file name, so a dollar_sign is used instead. + + 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 + if Hostparm.OpenVMS then + Buffer (2) := '$'; + else + Buffer (2) := '~'; + end if; + + 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; + + -- 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; |