diff options
author | Ben Cheng <bccheng@google.com> | 2014-03-25 22:37:19 -0700 |
---|---|---|
committer | Ben Cheng <bccheng@google.com> | 2014-03-25 22:37:19 -0700 |
commit | 1bc5aee63eb72b341f506ad058502cd0361f0d10 (patch) | |
tree | c607e8252f3405424ff15bc2d00aa38dadbb2518 /gcc-4.9/gcc/ada/krunch.adb | |
parent | 283a0bf58fcf333c58a2a92c3ebbc41fb9eb1fdb (diff) | |
download | toolchain_gcc-1bc5aee63eb72b341f506ad058502cd0361f0d10.tar.gz toolchain_gcc-1bc5aee63eb72b341f506ad058502cd0361f0d10.tar.bz2 toolchain_gcc-1bc5aee63eb72b341f506ad058502cd0361f0d10.zip |
Initial checkin of GCC 4.9.0 from trunk (r208799).
Change-Id: I48a3c08bb98542aa215912a75f03c0890e497dba
Diffstat (limited to 'gcc-4.9/gcc/ada/krunch.adb')
-rw-r--r-- | gcc-4.9/gcc/ada/krunch.adb | 265 |
1 files changed, 265 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/krunch.adb b/gcc-4.9/gcc/ada/krunch.adb new file mode 100644 index 000000000..f2bbf05dc --- /dev/null +++ b/gcc-4.9/gcc/ada/krunch.adb @@ -0,0 +1,265 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- K R U N C H -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2009, 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. -- +-- -- +------------------------------------------------------------------------------ + +with Hostparm; + +procedure Krunch + (Buffer : in out String; + Len : in out Natural; + Maxlen : Natural; + No_Predef : Boolean; + VMS_On_Target : Boolean := False) + +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. On VMS a tilde is an illegal character + -- in a file name, two consecutive underlines ("__") are 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 + -- When VMS is the host, it is always also the target + + if Hostparm.OpenVMS or else VMS_On_Target then + Len := Len + 1; + Buffer (4 .. Len) := Buffer (3 .. Len - 1); + Buffer (2) := '_'; + Buffer (3) := '_'; + else + Buffer (2) := '~'; + end if; + + if Len <= Maxlen then + return; + + else + -- Case of VMS when the buffer had exactly the length Maxlen and now + -- has the length Maxlen + 1: krunching after "__" is needed. + + Startloc := 4; + Curlen := Len; + Krlen := Maxlen; + end if; + + -- 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; |