aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.4.0/gcc/ada/krunch.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.4.0/gcc/ada/krunch.adb')
-rw-r--r--gcc-4.4.0/gcc/ada/krunch.adb265
1 files changed, 265 insertions, 0 deletions
diff --git a/gcc-4.4.0/gcc/ada/krunch.adb b/gcc-4.4.0/gcc/ada/krunch.adb
new file mode 100644
index 000000000..f2bbf05dc
--- /dev/null
+++ b/gcc-4.4.0/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;