-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2010, AdaCore --
+-- Copyright (C) 2002-2011, AdaCore --
-- --
-- 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- --
+-- 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. 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, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
--- 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. --
+-- 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. --
No_Table : constant Table_Id := -1;
type Word_Type is new String_Access;
- procedure Free_Word (W : in out Word_Type);
+ procedure Free_Word (W : in out Word_Type) renames Free;
function New_Word (S : String) return Word_Type;
procedure Resize_Word (W : in out Word_Type; Len : Natural);
-- Return a string which includes string Str or integer Int preceded by
-- leading spaces if required by width W.
+ function Trim_Trailing_Nuls (Str : String) return String;
+ -- Return Str with trailing NUL characters removed
+
Output : File_Descriptor renames GNAT.OS_Lib.Standout;
-- Shortcuts
---------
procedure Add (C : Character) is
+ pragma Assert (C /= ASCII.NUL);
begin
Line (Last + 1) := C;
Last := Last + 1;
procedure Add (S : String) is
Len : constant Natural := S'Length;
begin
+ for J in S'Range loop
+ pragma Assert (S (J) /= ASCII.NUL);
+ null;
+ end loop;
+
Line (Last + 1 .. Last + Len) := S;
Last := Last + Len;
end Add;
-- Allocate --
--------------
- function Allocate (N : Natural; S : Natural := 1) return Table_Id is
+ function Allocate (N : Natural; S : Natural := 1) return Table_Id is
L : constant Integer := IT.Last;
begin
IT.Set_Last (L + N * S);
+
+ -- Initialize, so debugging printouts don't trip over uninitialized
+ -- components.
+
+ for J in L + 1 .. IT.Last loop
+ IT.Table (J) := -1;
+ end loop;
+
return L + 1;
end Allocate;
New_Line (Output);
end if;
- -- Deallocate all the WT components (both initial and reduced
- -- ones) to avoid memory leaks.
+ -- Deallocate all the WT components (both initial and reduced ones) to
+ -- avoid memory leaks.
for W in 0 .. WT.Last loop
- Free_Word (WT.Table (W));
+
+ -- Note: WT.Table (NK) is a temporary variable, do not free it since
+ -- this would cause a double free.
+
+ if W /= NK then
+ Free_Word (WT.Table (W));
+ end if;
end loop;
+
WT.Release;
IT.Release;
Min_Key_Len := 0;
end Finalize;
- ---------------
- -- Free_Word --
- ---------------
-
- procedure Free_Word (W : in out Word_Type) is
- begin
- if W /= null then
- Free (W);
- end if;
- end Free_Word;
-
----------------------------
-- Generate_Mapping_Table --
----------------------------
procedure Initialize
(Seed : Natural;
K_To_V : Float := Default_K_To_V;
- Optim : Optimization := CPU_Time;
+ Optim : Optimization := Memory_Space;
Tries : Positive := Default_Tries)
is
begin
-- explicitly initialized to null.
WT.Set_Last (Reduced (NK - 1));
+
+ -- Note: Reduced (0) = NK + 1
+
+ WT.Table (NK) := null;
+
for W in 0 .. NK - 1 loop
WT.Table (Reduced (W)) := null;
end loop;
New_Line (Output);
end if;
+ for J in Value'Range loop
+ pragma Assert (Value (J) /= ASCII.NUL);
+ null;
+ end loop;
+
WT.Set_Last (NK);
WT.Table (NK) := New_Word (Value);
NK := NK + 1;
-- Produce --
-------------
- procedure Produce (Pkg_Name : String := Default_Pkg_Name) is
- File : File_Descriptor;
+ procedure Produce
+ (Pkg_Name : String := Default_Pkg_Name;
+ Use_Stdout : Boolean := False)
+ is
+ File : File_Descriptor := Standout;
Status : Boolean;
-- For call to Close
P : Natural;
FName : String := Ada_File_Base_Name (Pkg_Name) & ".ads";
- -- Initially, the name of the spec file; then modified to be the name of
- -- the body file.
+ -- Initially, the name of the spec file, then modified to be the name of
+ -- the body file. Not used if Use_Stdout is True.
-- Start of processing for Produce
begin
- if Verbose then
+ if Verbose and then not Use_Stdout then
Put (Output,
"Producing " & Ada.Directories.Current_Directory & "/" & FName);
New_Line (Output);
end if;
- File := Create_File (FName, Binary);
+ if not Use_Stdout then
+ File := Create_File (FName, Binary);
- if File = Invalid_FD then
- raise Program_Error with "cannot create: " & FName;
+ if File = Invalid_FD then
+ raise Program_Error with "cannot create: " & FName;
+ end if;
end if;
Put (File, "package ");
Put (File, Pkg_Name);
Put (File, ";");
New_Line (File);
- Close (File, Status);
- if not Status then
- raise Device_Error;
+ if not Use_Stdout then
+ Close (File, Status);
+
+ if not Status then
+ raise Device_Error;
+ end if;
end if;
- FName (FName'Last) := 'b'; -- Set to body file name
+ if not Use_Stdout then
+
+ -- Set to body file name
- File := Create_File (FName, Binary);
+ FName (FName'Last) := 'b';
- if File = Invalid_FD then
- raise Program_Error with "cannot create: " & FName;
+ File := Create_File (FName, Binary);
+
+ if File = Invalid_FD then
+ raise Program_Error with "cannot create: " & FName;
+ end if;
end if;
Put (File, "with Interfaces; use Interfaces;");
New_Line (File);
- if Opt = CPU_Time then
- Put_Int_Matrix
- (File,
- Array_Img ("T1", Type_Img (NV),
- Range_Img (0, T1_Len - 1),
- Range_Img (0, T2_Len - 1, Type_Img (256))),
- T1, T1_Len, T2_Len);
-
- else
- Put_Int_Matrix
- (File,
- Array_Img ("T1", Type_Img (NV),
- Range_Img (0, T1_Len - 1)),
- T1, T1_Len, 0);
- end if;
+ case Opt is
+ when CPU_Time =>
+ Put_Int_Matrix
+ (File,
+ Array_Img ("T1", Type_Img (NV),
+ Range_Img (0, T1_Len - 1),
+ Range_Img (0, T2_Len - 1, Type_Img (256))),
+ T1, T1_Len, T2_Len);
+
+ when Memory_Space =>
+ Put_Int_Matrix
+ (File,
+ Array_Img ("T1", Type_Img (NV),
+ Range_Img (0, T1_Len - 1)),
+ T1, T1_Len, 0);
+ end case;
New_Line (File);
- if Opt = CPU_Time then
- Put_Int_Matrix
- (File,
- Array_Img ("T2", Type_Img (NV),
- Range_Img (0, T1_Len - 1),
- Range_Img (0, T2_Len - 1, Type_Img (256))),
- T2, T1_Len, T2_Len);
-
- else
- Put_Int_Matrix
- (File,
- Array_Img ("T2", Type_Img (NV),
- Range_Img (0, T1_Len - 1)),
- T2, T1_Len, 0);
- end if;
+ case Opt is
+ when CPU_Time =>
+ Put_Int_Matrix
+ (File,
+ Array_Img ("T2", Type_Img (NV),
+ Range_Img (0, T1_Len - 1),
+ Range_Img (0, T2_Len - 1, Type_Img (256))),
+ T2, T1_Len, T2_Len);
+
+ when Memory_Space =>
+ Put_Int_Matrix
+ (File,
+ Array_Img ("T2", Type_Img (NV),
+ Range_Img (0, T1_Len - 1)),
+ T2, T1_Len, 0);
+ end case;
New_Line (File);
Put (File, " J : ");
- if Opt = CPU_Time then
- Put (File, Type_Img (256));
- else
- Put (File, "Natural");
- end if;
+ case Opt is
+ when CPU_Time =>
+ Put (File, Type_Img (256));
+ when Memory_Space =>
+ Put (File, "Natural");
+ end case;
Put (File, ";");
New_Line (File);
New_Line (File);
Put (File, " J := ");
- if Opt = CPU_Time then
- Put (File, "C");
- else
- Put (File, "Character'Pos");
- end if;
+ case Opt is
+ when CPU_Time =>
+ Put (File, "C");
+ when Memory_Space =>
+ Put (File, "Character'Pos");
+ end case;
Put (File, " (S (P (K) + F));");
New_Line (File);
Put (File, Pkg_Name);
Put (File, ";");
New_Line (File);
- Close (File, Status);
- if not Status then
- raise Device_Error;
+ if not Use_Stdout then
+ Close (File, Status);
+
+ if not Status then
+ raise Device_Error;
+ end if;
end if;
end Produce;
procedure Put (File : File_Descriptor; Str : String) is
Len : constant Natural := Str'Length;
begin
+ for J in Str'Range loop
+ pragma Assert (Str (J) /= ASCII.NUL);
+ null;
+ end loop;
+
if Write (File, Str'Address, Len) /= Len then
raise Program_Error;
end if;
Last := 0;
end if;
- if Last + Len + 3 > Max then
+ if Last + Len + 3 >= Max then
Flush;
end if;
if Last = 0 then
- Line (Last + 1 .. Last + 5) := " ";
- Last := Last + 5;
+ Add (" ");
if F1 <= L1 then
if C1 = F1 and then C2 = F2 then
Add (' ');
end if;
- Line (Last + 1 .. Last + Len) := S;
- Last := Last + Len;
+ Add (S);
if C2 = L2 then
Add (')');
K := Get_Key (J);
Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2);
- Put (File, WT.Table (Initial (J)).all, F1, L1, J, 1, 3, 3);
+ Put (File, Trim_Trailing_Nuls (WT.Table (Initial (J)).all),
+ F1, L1, J, 1, 3, 3);
end loop;
end Put_Initial_Keys;
K := Get_Key (J);
Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2);
- Put (File, WT.Table (Reduced (J)).all, F1, L1, J, 1, 3, 3);
+ Put (File, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all),
+ F1, L1, J, 1, 3, 3);
end loop;
end Put_Reduced_Keys;
Same_Keys_Sets_Table (J).First ..
Same_Keys_Sets_Table (J).Last
loop
- Put (Output, WT.Table (Reduced (K)).all);
+ Put (Output,
+ Trim_Trailing_Nuls (WT.Table (Reduced (K)).all));
New_Line (Output);
end loop;
Put (Output, "--");
R : Natural;
begin
- if Opt = CPU_Time then
- for J in 0 .. T1_Len - 1 loop
- exit when Word (J + 1) = ASCII.NUL;
- R := Get_Table (Table, J, Get_Used_Char (Word (J + 1)));
- S := (S + R) mod NV;
- end loop;
+ case Opt is
+ when CPU_Time =>
+ for J in 0 .. T1_Len - 1 loop
+ exit when Word (J + 1) = ASCII.NUL;
+ R := Get_Table (Table, J, Get_Used_Char (Word (J + 1)));
+ S := (S + R) mod NV;
+ end loop;
- else
- for J in 0 .. T1_Len - 1 loop
- exit when Word (J + 1) = ASCII.NUL;
- R := Get_Table (Table, J, 0);
- S := (S + R * Character'Pos (Word (J + 1))) mod NV;
- end loop;
- end if;
+ when Memory_Space =>
+ for J in 0 .. T1_Len - 1 loop
+ exit when Word (J + 1) = ASCII.NUL;
+ R := Get_Table (Table, J, 0);
+ S := (S + R * Character'Pos (Word (J + 1))) mod NV;
+ end loop;
+ end case;
return S;
end Sum;
+ ------------------------
+ -- Trim_Trailing_Nuls --
+ ------------------------
+
+ function Trim_Trailing_Nuls (Str : String) return String is
+ begin
+ for J in reverse Str'Range loop
+ if Str (J) /= ASCII.NUL then
+ return Str (Str'First .. J);
+ end if;
+ end loop;
+
+ return Str;
+ end Trim_Trailing_Nuls;
+
---------------
-- Type_Size --
---------------