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;
J : Natural;
begin
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;
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;
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;
else
Startloc := 1;
Curlen := Len;
Krlen := Maxlen;
end if;
if Curlen <= Krlen then
Len := Curlen;
return;
end if;
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 J in 1 .. Curlen loop
if Buffer (J) = ASCII.ESC then
return;
end if;
end loop;
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;
while Curlen - Num_Seps > Krlen loop
declare
Long_Length : Natural := 0;
Long_Last : Natural := 0;
Piece_Start : Natural;
Ptr : Natural;
begin
Ptr := Startloc;
while Ptr <= Curlen loop
Piece_Start := Ptr;
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;
if Long_Last < Curlen then
Buffer (Long_Last .. Curlen - 1) :=
Buffer (Long_Last + 1 .. Curlen);
end if;
Curlen := Curlen - 1;
end;
end loop;
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;