s-imaged$(objext) \
s-imagef$(objext) \
s-imagei$(objext) \
+ s-imagen$(objext) \
s-imager$(objext) \
s-imageu$(objext) \
s-imagew$(objext) \
s-imde32$(objext) \
s-imde64$(objext) \
- s-imenne$(objext) \
+ s-imen16$(objext) \
+ s-imen32$(objext) \
+ s-imenu8$(objext) \
s-imfi32$(objext) \
s-imfi64$(objext) \
s-imgbiu$(objext) \
s-imgboo$(objext) \
s-imgcha$(objext) \
- s-imgenu$(objext) \
s-imgflt$(objext) \
s-imgint$(objext) \
s-imglfl$(objext) \
s-pack63$(objext) \
s-parame$(objext) \
s-parint$(objext) \
+ s-pehage$(objext) \
s-pooglo$(objext) \
s-pooloc$(objext) \
s-poosiz$(objext) \
s-valcha$(objext) \
s-vade32$(objext) \
s-vade64$(objext) \
+ s-vaen16$(objext) \
+ s-vaen32$(objext) \
+ s-vaenu8$(objext) \
s-vafi32$(objext) \
s-vafi64$(objext) \
- s-valenu$(objext) \
s-valflt$(objext) \
s-valint$(objext) \
s-vallfl$(objext) \
s-valued$(objext) \
s-valuef$(objext) \
s-valuei$(objext) \
+ s-valuen$(objext) \
s-valuer$(objext) \
s-valueu$(objext) \
s-valuns$(objext) \
-- d_e Ignore entry calls and requeue statements for elaboration
-- d_f Issue info messages related to GNATprove usage
-- d_g
- -- d_h
+ -- d_h Disable the use of (perfect) hash functions for enumeration Value
-- d_i Ignore activations and calls to instances for elaboration
-- d_j Read JSON files and populate Repinfo tables (opposite of -gnatRjs)
-- d_k
-- beginners find them confusing. Set automatically by GNATprove when
-- switch --info is used.
+ -- d_h The compiler does not make use of (perfect) hash functions in the
+ -- implementation of the Value attribute for enumeration types.
+
-- d_i The compiler ignores calls and task activations when they target a
-- subprogram or task type defined in an external instance for both
-- the static and dynamic elaboration models.
-- Corresponding_Record_Component Node21
-- Default_Expr_Function Node21
-- Discriminant_Constraint Elist21
+ -- Lit_Hash Node21
-- Interface_Name Node21
-- Original_Array_Type Node21
-- Small_Value Ureal21
return Node33 (Id);
end Linker_Section_Pragma;
+ function Lit_Hash (Id : E) return E is
+ begin
+ pragma Assert (Is_Enumeration_Type (Id));
+ return Node21 (Id);
+ end Lit_Hash;
+
function Lit_Indexes (Id : E) return E is
begin
pragma Assert (Is_Enumeration_Type (Id));
Set_Node33 (Id, V);
end Set_Linker_Section_Pragma;
+ procedure Set_Lit_Hash (Id : E; V : E) is
+ begin
+ pragma Assert (Is_Enumeration_Type (Id) and then Root_Type (Id) = Id);
+ Set_Node21 (Id, V);
+ end Set_Lit_Hash;
+
procedure Set_Lit_Indexes (Id : E; V : E) is
begin
pragma Assert (Is_Enumeration_Type (Id) and then Root_Type (Id) = Id);
=>
Write_Str ("Interface_Name");
+ when Enumeration_Kind =>
+ Write_Str ("Lit_Hash");
+
when Array_Kind
| Modular_Integer_Kind
=>
-- field may be set as a result of a linker section pragma applied to the
-- type of the object.
+-- Lit_Hash (Node21)
+-- Defined in enumeration types and subtypes. Non-empty only for the
+-- case of an enumeration root type, where it contains the entity for
+-- the generated hash function. See unit Exp_Imgv for full details of
+-- the nature and use of this entity for implementing the Value
+-- attribute for the enumeration type in question.
+
-- Lit_Indexes (Node18)
-- Defined in enumeration types and subtypes. Non-empty only for the
-- case of an enumeration root type, where it contains the entity for
-- Lit_Indexes (Node18) (root type only)
-- Default_Aspect_Value (Node19) (base type only)
-- Scalar_Range (Node20)
+ -- Lit_Hash (Node21) (root type only)
-- Enum_Pos_To_Rep (Node23) (type only)
-- Static_Discrete_Predicate (List25)
-- Has_Biased_Representation (Flag139)
function Last_Entity (Id : E) return E;
function Limited_View (Id : E) return E;
function Linker_Section_Pragma (Id : E) return N;
+ function Lit_Hash (Id : E) return E;
function Lit_Indexes (Id : E) return E;
function Lit_Strings (Id : E) return E;
function Low_Bound_Tested (Id : E) return B;
procedure Set_Last_Entity (Id : E; V : E);
procedure Set_Limited_View (Id : E; V : E);
procedure Set_Linker_Section_Pragma (Id : E; V : N);
+ procedure Set_Lit_Hash (Id : E; V : E);
procedure Set_Lit_Indexes (Id : E; V : E);
procedure Set_Lit_Strings (Id : E; V : E);
procedure Set_Low_Bound_Tested (Id : E; V : B := True);
pragma Inline (Limited_View);
pragma Inline (Link_Entities);
pragma Inline (Linker_Section_Pragma);
+ pragma Inline (Lit_Hash);
pragma Inline (Lit_Indexes);
pragma Inline (Lit_Strings);
pragma Inline (Low_Bound_Tested);
pragma Inline (Set_Last_Entity);
pragma Inline (Set_Limited_View);
pragma Inline (Set_Linker_Section_Pragma);
+ pragma Inline (Set_Lit_Hash);
pragma Inline (Set_Lit_Indexes);
pragma Inline (Set_Lit_Strings);
pragma Inline (Set_Low_Bound_Tested);
with Atree; use Atree;
with Casing; use Casing;
with Checks; use Checks;
+with Debug; use Debug;
with Einfo; use Einfo;
with Exp_Put_Image;
with Exp_Util; use Exp_Util;
with Uintp; use Uintp;
with Urealp; use Urealp;
+with System.Perfect_Hash_Generators;
+
package body Exp_Imgv is
procedure Rewrite_Object_Image
------------------------------------
procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (E);
+ Loc : constant Source_Ptr := Sloc (E);
+ In_Main_Unit : constant Boolean := In_Extended_Main_Code_Unit (Loc);
+ Act : List_Id;
Eind : Entity_Id;
Estr : Entity_Id;
+ H_Id : Entity_Id;
+ H_OK : Boolean;
+ H_Sp : Node_Id;
Ind : List_Id;
Ityp : Node_Id;
Len : Nat;
Lit : Entity_Id;
Nlit : Nat;
+ S_Id : Entity_Id;
+ S_N : Nat;
Str : String_Id;
+ package SPHG renames System.Perfect_Hash_Generators;
+
Saved_SSO : constant Character := Opt.Default_SSO;
-- Used to save the current scalar storage order during the generation
-- of the literal lookup table.
+ Serial_Number_Budget : constant := 50;
+ -- We may want to compute a perfect hash function for use by the Value
+ -- attribute. However computing this function is costly and, therefore,
+ -- cannot be done when compiling every unit where the enumeration type
+ -- is referenced, so we do it only when compiling the unit where it is
+ -- declared. This means that we may need to control the internal serial
+ -- numbers of this unit, or else we would risk generating public symbols
+ -- with mismatched names later on. The strategy for this is to allocate
+ -- a fixed budget of serial numbers to be spent from a specified point
+ -- until the end of the processing and to make sure that it is always
+ -- exactly spent on all possible paths from this point.
+
+ Threshold : constant := 3;
+ -- Threshold above which we want to generate the hash function in the
+ -- default case.
+
+ Threshold_For_Size : constant := 9;
+ -- But the function and its tables take a bit of space so the threshold
+ -- is raised when compiling for size.
+
+ procedure Append_Table_To
+ (L : List_Id;
+ E : Entity_Id;
+ UB : Nat;
+ Ctyp : Entity_Id;
+ V : List_Id);
+ -- Append to L the declaration of E as a constant array of range 0 .. UB
+ -- and component type Ctyp with initial value V.
+
+ ---------------------
+ -- Append_Table_To --
+ ---------------------
+
+ procedure Append_Table_To
+ (L : List_Id;
+ E : Entity_Id;
+ UB : Nat;
+ Ctyp : Entity_Id;
+ V : List_Id)
+ is
+ begin
+ Append_To (L,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => E,
+ Constant_Present => True,
+ Object_Definition =>
+ Make_Constrained_Array_Definition (Loc,
+ Discrete_Subtype_Definitions => New_List (
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 0),
+ High_Bound => Make_Integer_Literal (Loc, UB))),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Occurrence_Of (Ctyp, Loc))),
+ Expression => Make_Aggregate (Loc, Expressions => V)));
+ end Append_Table_To;
+
begin
-- Nothing to do for types other than a root enumeration type
Lit := First_Literal (E);
Len := 1;
Nlit := 0;
+ H_OK := False;
loop
- Append_To (Ind,
- Make_Integer_Literal (Loc, UI_From_Int (Len)));
+ Append_To (Ind, Make_Integer_Literal (Loc, UI_From_Int (Len)));
exit when No (Lit);
Nlit := Nlit + 1;
end if;
Store_String_Chars (Name_Buffer (1 .. Name_Len));
+ if In_Main_Unit then
+ SPHG.Insert (Name_Buffer (1 .. Name_Len));
+ end if;
Len := Len + Int (Name_Len);
Next_Literal (Lit);
end loop;
-- Generate literal table
- Insert_Actions (N,
+ Act :=
New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Estr,
New_Occurrence_Of (Standard_String, Loc),
Expression =>
Make_String_Literal (Loc,
- Strval => Str)),
+ Strval => Str)));
- Make_Object_Declaration (Loc,
- Defining_Identifier => Eind,
- Constant_Present => True,
+ -- Generate index table
- Object_Definition =>
- Make_Constrained_Array_Definition (Loc,
- Discrete_Subtype_Definitions => New_List (
- Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 0),
- High_Bound => Make_Integer_Literal (Loc, Nlit))),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication => New_Occurrence_Of (Ityp, Loc))),
+ Append_Table_To (Act, Eind, Nlit, Ityp, Ind);
- Expression =>
- Make_Aggregate (Loc,
- Expressions => Ind))),
- Suppress => All_Checks);
+ -- If the number of literals is at most 3, then we are done. Otherwise
+ -- we compute a (perfect) hash function for use by the Value attribute.
+
+ if Nlit > Threshold then
+ -- We start to count serial numbers from here
+
+ S_N := Increment_Serial_Number;
+
+ -- Generate specification of hash function
+
+ H_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (E), 'H'));
+ Set_Ekind (H_Id, E_Function);
+ Set_Is_Internal (H_Id);
+
+ if not Debug_Generated_Code then
+ Set_Debug_Info_Off (H_Id);
+ end if;
+
+ Set_Lit_Hash (E, H_Id);
+
+ S_Id := Make_Temporary (Loc, 'S');
+
+ H_Sp := Make_Function_Specification (Loc,
+ Defining_Unit_Name => H_Id,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => S_Id,
+ Parameter_Type =>
+ New_Occurrence_Of (Standard_String, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Natural, Loc));
+
+ -- If the unit where the type is declared is the main unit, and the
+ -- number of literals is greater than Threshold_For_Size when we are
+ -- optimizing for size, and -gnatd_h is not specified, try to compute
+ -- the hash function.
+
+ if In_Main_Unit
+ and then (Optimize_Size = 0 or else Nlit > Threshold_For_Size)
+ and then not Debug_Flag_Underscore_H
+ then
+ declare
+ LB : constant Positive := 2 * Positive (Nlit) + 1;
+ UB : constant Positive := LB + 24;
+
+ begin
+ -- Try at most 25 * 4 times to compute the hash function before
+ -- giving up and using a linear search for the Value attribute.
+
+ for V in LB .. UB loop
+ begin
+ SPHG.Initialize (4321, V, SPHG.Memory_Space, Tries => 4);
+ SPHG.Compute ("");
+ H_OK := True;
+ exit;
+ exception
+ when SPHG.Too_Many_Tries => null;
+ end;
+ end loop;
+ end;
+ end if;
+
+ -- If the hash function has been successfully computed, 4 more tables
+ -- named P, T1, T2 and G are needed. The hash function is of the form
+
+ -- function Hash (S : String) return Natural is
+ -- F : constant Natural := S'First - 1;
+ -- L : constant Natural := S'Length;
+ -- A, B : Natural := 0;
+ -- J : Natural;
+
+ -- begin
+ -- for K in P'Range loop
+ -- exit when L < P (K);
+ -- J := Character'Pos (S (P (K) + F));
+ -- A := (A + Natural (T1 (K) * J)) mod N;
+ -- B := (B + Natural (T2 (K) * J)) mod N;
+ -- end loop;
+
+ -- return (Natural (G (A)) + Natural (G (B))) mod M;
+ -- end Hash;
+
+ -- where N is the length of G and M the number of literals.
+
+ if H_OK then
+ declare
+ Siz, L1, L2 : Natural;
+ I : Int;
+
+ Pos, T1, T2, G : List_Id;
+ EPos, ET1, ET2, EG : Entity_Id;
+
+ F, L, A, B, J, K : Entity_Id;
+ Body_Decls : List_Id;
+ Body_Stmts : List_Id;
+ Loop_Stmts : List_Id;
+
+ begin
+ -- Generate position table
+
+ SPHG.Define (SPHG.Character_Position, Siz, L1, L2);
+ Pos := New_List;
+ for J in 0 .. L1 - 1 loop
+ I := Int (SPHG.Value (SPHG.Character_Position, J));
+ Append_To (Pos, Make_Integer_Literal (Loc, UI_From_Int (I)));
+ end loop;
+
+ EPos :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (E), 'P'));
+
+ Append_Table_To
+ (Act, EPos, Nat (L1 - 1), Standard_Natural, Pos);
+
+ -- Generate function table 1
+
+ SPHG.Define (SPHG.Function_Table_1, Siz, L1, L2);
+ T1 := New_List;
+ for J in 0 .. L1 - 1 loop
+ I := Int (SPHG.Value (SPHG.Function_Table_1, J));
+ Append_To (T1, Make_Integer_Literal (Loc, UI_From_Int (I)));
+ end loop;
+
+ ET1 :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (E), "T1"));
+
+ Ityp :=
+ Small_Integer_Type_For (UI_From_Int (Int (Siz)), Uns => True);
+ Append_Table_To (Act, ET1, Nat (L1 - 1), Ityp, T1);
+
+ -- Generate function table 2
+
+ SPHG.Define (SPHG.Function_Table_2, Siz, L1, L2);
+ T2 := New_List;
+ for J in 0 .. L1 - 1 loop
+ I := Int (SPHG.Value (SPHG.Function_Table_2, J));
+ Append_To (T2, Make_Integer_Literal (Loc, UI_From_Int (I)));
+ end loop;
+
+ ET2 :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (E), "T2"));
+
+ Ityp :=
+ Small_Integer_Type_For (UI_From_Int (Int (Siz)), Uns => True);
+ Append_Table_To (Act, ET2, Nat (L1 - 1), Ityp, T2);
+
+ -- Generate graph table
+
+ SPHG.Define (SPHG.Graph_Table, Siz, L1, L2);
+ G := New_List;
+ for J in 0 .. L1 - 1 loop
+ I := Int (SPHG.Value (SPHG.Graph_Table, J));
+ Append_To (G, Make_Integer_Literal (Loc, UI_From_Int (I)));
+ end loop;
+
+ EG :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (E), 'G'));
+
+ Ityp :=
+ Small_Integer_Type_For (UI_From_Int (Int (Siz)), Uns => True);
+ Append_Table_To (Act, EG, Nat (L1 - 1), Ityp, G);
+
+ -- Generate body of hash function
+
+ F := Make_Temporary (Loc, 'F');
+
+ Body_Decls := New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => F,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Natural, Loc),
+ Expression =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (S_Id, Loc),
+ Attribute_Name => Name_First),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, 1))));
+
+ L := Make_Temporary (Loc, 'L');
+
+ Append_To (Body_Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => L,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Natural, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (S_Id, Loc),
+ Attribute_Name => Name_Length)));
+
+ A := Make_Temporary (Loc, 'A');
+
+ Append_To (Body_Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => A,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Natural, Loc),
+ Expression => Make_Integer_Literal (Loc, 0)));
+
+ B := Make_Temporary (Loc, 'B');
+
+ Append_To (Body_Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => B,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Natural, Loc),
+ Expression => Make_Integer_Literal (Loc, 0)));
+
+ J := Make_Temporary (Loc, 'J');
+
+ Append_To (Body_Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => J,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Natural, Loc)));
+
+ K := Make_Temporary (Loc, 'K');
+
+ -- Generate exit when L < P (K);
+
+ Loop_Stmts := New_List (
+ Make_Exit_Statement (Loc,
+ Condition =>
+ Make_Op_Lt (Loc,
+ Left_Opnd => New_Occurrence_Of (L, Loc),
+ Right_Opnd =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (EPos, Loc),
+ Expressions => New_List (
+ New_Occurrence_Of (K, Loc))))));
+
+ -- Generate J := Character'Pos (S (P (K) + F));
+
+ Append_To (Loop_Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (J, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Standard_Character, Loc),
+ Attribute_Name => Name_Pos,
+ Expressions => New_List (
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (S_Id, Loc),
+ Expressions => New_List (
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (EPos, Loc),
+ Expressions => New_List (
+ New_Occurrence_Of (K, Loc))),
+ Right_Opnd =>
+ New_Occurrence_Of (F, Loc))))))));
+
+ -- Generate A := (A + Natural (T1 (K) * J)) mod N;
+
+ Append_To (Loop_Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (A, Loc),
+ Expression =>
+ Make_Op_Mod (Loc,
+ Left_Opnd =>
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Occurrence_Of (A, Loc),
+ Right_Opnd =>
+ Make_Op_Multiply (Loc,
+ Left_Opnd =>
+ Convert_To (Standard_Natural,
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (ET1, Loc),
+ Expressions => New_List (
+ New_Occurrence_Of (K, Loc)))),
+ Right_Opnd => New_Occurrence_Of (J, Loc))),
+ Right_Opnd => Make_Integer_Literal (Loc, Int (L1)))));
+
+ -- Generate B := (B + Natural (T2 (K) * J)) mod N;
+
+ Append_To (Loop_Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (B, Loc),
+ Expression =>
+ Make_Op_Mod (Loc,
+ Left_Opnd =>
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Occurrence_Of (B, Loc),
+ Right_Opnd =>
+ Make_Op_Multiply (Loc,
+ Left_Opnd =>
+ Convert_To (Standard_Natural,
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (ET2, Loc),
+ Expressions => New_List (
+ New_Occurrence_Of (K, Loc)))),
+ Right_Opnd => New_Occurrence_Of (J, Loc))),
+ Right_Opnd => Make_Integer_Literal (Loc, Int (L1)))));
+
+ -- Generate loop
+
+ Body_Stmts := New_List (
+ Make_Implicit_Loop_Statement (N,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => K,
+ Discrete_Subtype_Definition =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (EPos, Loc),
+ Attribute_Name => Name_Range))),
+ Statements => Loop_Stmts));
+
+ -- Generate return (Natural (G (A)) + Natural (G (B))) mod M;
+
+ Append_To (Body_Stmts,
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Op_Mod (Loc,
+ Left_Opnd =>
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Convert_To (Standard_Natural,
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (EG, Loc),
+ Expressions => New_List (
+ New_Occurrence_Of (A, Loc)))),
+ Right_Opnd =>
+ Convert_To (Standard_Natural,
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (EG, Loc),
+ Expressions => New_List (
+ New_Occurrence_Of (B, Loc))))),
+ Right_Opnd => Make_Integer_Literal (Loc, Nlit))));
+
+ -- Generate final body
+
+ Append_To (Act,
+ Make_Subprogram_Body (Loc,
+ Specification => H_Sp,
+ Declarations => Body_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Body_Stmts)));
+ end;
+
+ -- If we chose not to or did not manage to compute the hash function,
+ -- we need to build a dummy function always returning Natural'Last
+ -- because other units reference it if they use the Value attribute.
+
+ elsif In_Main_Unit then
+ declare
+ Body_Stmts : List_Id;
+
+ begin
+ -- Generate return Natural'Last
+
+ Body_Stmts := New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Standard_Natural, Loc),
+ Attribute_Name => Name_Last)));
+
+ -- Generate body
+
+ Append_To (Act,
+ Make_Subprogram_Body (Loc,
+ Specification => H_Sp,
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Body_Stmts)));
+ end;
+
+ -- For the other units, just declare the function
+
+ else
+ Append_To (Act,
+ Make_Subprogram_Declaration (Loc, Specification => H_Sp));
+ end if;
+
+ else
+ Set_Lit_Hash (E, Empty);
+ end if;
+
+ if In_Main_Unit then
+ System.Perfect_Hash_Generators.Finalize;
+ end if;
+
+ Insert_Actions (N, Act, Suppress => All_Checks);
+
+ -- This is where we check that our budget of serial numbers has been
+ -- entirely spent, see the declaration of Serial_Number_Budget above.
+
+ if Nlit > Threshold then
+ Synchronize_Serial_Number (S_N + Serial_Number_Budget);
+ end if;
-- Reset the scalar storage order to the saved value
-- For enumeration types other than those derived from types Boolean,
-- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
- -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
+ -- Enum'Val
+ -- (Value_Enumeration_NN
+ -- (typS, typN'Address, typH'Unrestricted_Access, Num, X))
- -- where typS and typI and the Lit_Strings and Lit_Indexes entities
- -- from T's root type entity, and Num is Enum'Pos (Enum'Last). The
- -- Value_Enumeration_NN function will search the tables looking for
+ -- where typS, typN and typH are the Lit_Strings, Lit_Indexes and Lit_Hash
+ -- entities from T's root type entity, and Num is Enum'Pos (Enum'Last).
+ -- The Value_Enumeration_NN function will search the tables looking for
-- X and return the position number in the table if found which is
-- used to provide the result of 'Value (using Enum'Val). If the
-- value is not found Constraint_Error is raised. The suffix _NN
- -- depends on the element type of typI.
+ -- depends on the element type of typN.
procedure Expand_Value_Attribute (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Analyze_And_Resolve (N, Btyp);
- -- Here for normal case where we have enumeration tables, this
- -- is where we build
+ -- Normal case where we have enumeration tables, build
- -- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
+ -- T'Val
+ -- (Value_Enumeration_NN
+ -- (typS, typN'Address, typH'Unrestricted_Access, Num, X))
else
Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
Prefix => New_Occurrence_Of (Rtyp, Loc),
Attribute_Name => Name_Last))));
+ if Present (Lit_Hash (Rtyp)) then
+ Prepend_To (Args,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Lit_Hash (Rtyp), Loc),
+ Attribute_Name => Name_Unrestricted_Access));
+ else
+ Prepend_To (Args, Make_Null (Loc));
+ end if;
+
Prepend_To (Args,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
-- base type. The node N is the point in the tree where the resulting
-- declarations are to be inserted.
--
- -- The form of the tables generated is as follows:
+ -- The form of the tables generated is as follows:
--
- -- xxxS : string := "chars";
- -- xxxI : array (0 .. N) of Natural_8/16/32 := (1, n, .., n);
+ -- xxxS : constant string (1 .. M) := "chars";
+ -- xxxN : constant array (0 .. N) of Index_Type := (i1, i2, .., iN, j);
--
- -- Here xxxS is a string obtained by concatenating all the names
- -- of the enumeration literals in sequence, representing any wide
- -- characters according to the current wide character encoding
- -- method, and with all letters forced to upper case.
+ -- Here xxxS is a string obtained by concatenating all the names of the
+ -- enumeration literals in sequence, representing any wide characters
+ -- according to the current wide character encoding method, and with all
+ -- letters forced to upper case.
--
- -- The array xxxI is an array of ones origin indexes to the start
- -- of each name, with one extra entry at the end, which is the index
- -- to the character just past the end of the last literal, i.e. it is
- -- the length of xxxS + 1. The element type is the shortest of the
- -- possible types that will hold all the values.
+ -- The array xxxN is an array of indexes into xxxS pointing to the start
+ -- of each name, with one extra entry at the end, which is the index to
+ -- the character just past the end of the last literal, i.e. it is the
+ -- length of xxxS + 1. The element type is the shortest of the possible
+ -- types that will hold all the values.
--
- -- For example, for the type
+ -- For example, for the type
--
- -- type x is (hello,'!',goodbye);
+ -- type x is (hello,'!',goodbye);
--
- -- the generated tables would consist of
+ -- the generated tables would consist of
--
- -- xxxS : String := "hello'!'goodbye";
- -- xxxI : array (0 .. 3) of Natural_8 := (1, 6, 9, 16);
+ -- xxxS : constant string (1 .. 15) := "hello'!'goodbye";
+ -- xxxN : constant array (0 .. 3) of Integer_8 := (1, 6, 9, 16);
--
- -- Here Natural_8 is used since 16 < 2**(8-1)
+ -- Here Integer_8 is used since 16 < 2**(8-1).
--
- -- If the entity E needs the tables constructing, the necessary
- -- declarations are constructed, and the fields Lit_Strings and
- -- Lit_Indexes of E are set to point to the corresponding entities.
- -- If no tables are needed (E is not a user defined enumeration
- -- root type, or pragma Discard_Names is in effect, then the
- -- declarations are not constructed, and the fields remain Empty.
+ -- If the entity E needs the tables, the necessary declarations are built
+ -- and the fields Lit_Strings and Lit_Indexes of E are set to point to the
+ -- corresponding entities. If no tables are needed (E is not a user defined
+ -- enumeration root type, or pragma Discard_Names is in effect), then the
+ -- declarations are not constructed and the fields remain Empty.
+ --
+ -- If the number of enumeration literals is large enough, a (perfect) hash
+ -- function mapping the literals to their position number is also built and
+ -- requires in turn to build four additional tables:
+ --
+ -- xxxP : constant array (0 .. X - 1) of Natural = (p1, p2, ..., pX);
+ -- xxxT1 : constant array (0 .. Y - 1) of Index_Type = (q1, ..., qY);
+ -- xxxT2 : constant array (0 .. Y - 1) of Index_Type = (r1, ..., rY);
+ -- xxxG : constant array (0 .. Z - 1) of Index_Type = (s1, ..., sZ);
+ --
+ -- See the System.Perfect_Hash_Generators unit for a complete description.
procedure Expand_Image_Attribute (N : Node_Id);
-- This procedure is called from Exp_Attr to expand an occurrence of the
ada/libgnat/s-memory.o \
ada/libgnat/s-os_lib.o \
ada/libgnat/s-parame.o \
+ ada/libgnat/s-pehage.o \
ada/libgnat/s-purexc.o \
ada/libgnat/s-restri.o \
ada/libgnat/s-secsta.o \
ada/libgnat/s-exctab.o \
ada/libgnat/s-htable.o \
ada/libgnat/s-imenne.o \
- ada/libgnat/s-imgenu.o \
ada/libgnat/s-imgint.o \
ada/libgnat/s-mastop.o \
ada/libgnat/s-memory.o \
if Warning_Mode = Suppress then
Debug_Flag_MM := True;
end if;
+
+ -- The implementation of 'Value that uses a perfect hash function
+ -- is significantly more complex and harder to initialize than the
+ -- old implementation. Deactivate it for CodePeer.
+
+ Debug_Flag_Underscore_H := True;
end if;
-- Enable some individual switches that are implied by relaxed RM
-- Synchronize_Serial_Number --
-------------------------------
- procedure Synchronize_Serial_Number is
+ procedure Synchronize_Serial_Number (SN : Nat) is
TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number;
begin
- TSN := TSN + 1;
+ -- We should not be trying to synchronize downward
+
+ pragma Assert (TSN <= SN);
+
+ if TSN < SN then
+ TSN := SN;
+ end if;
end Synchronize_Serial_Number;
--------------------
-- This procedure is called to register a pragma N for which a notes
-- entry is required.
- procedure Synchronize_Serial_Number;
+ procedure Synchronize_Serial_Number (SN : Nat);
-- This function increments the Serial_Number field for the current unit
- -- but does not return the incremented value. This is used when there
- -- is a situation where one path of control increments a serial number
- -- (using Increment_Serial_Number), and the other path does not and it is
- -- important to keep the serial numbers synchronized in the two cases (e.g.
- -- when the references in a package and a client must be kept consistent).
+ -- up to SN if it is initially lower and does nothing otherwise. This is
+ -- used in situations where one path of control increments serial numbers
+ -- and the other path does not and it is important to keep serial numbers
+ -- synchronized in the two cases (e.g. when the references in a package
+ -- and a client must be kept consistent).
procedure Unlock;
-- Unlock internal tables, in cases where the back end needs to modify them
-- Note: GNAT.Heap_Sort replaces and obsoletes GNAT.Heap_Sort_A, which is
-- retained in the GNAT library for backwards compatibility.
+pragma Compiler_Unit_Warning;
+
package GNAT.Heap_Sort is
pragma Pure;
with Ada.IO_Exceptions; use Ada.IO_Exceptions;
with Ada.Characters.Handling; use Ada.Characters.Handling;
-with Ada.Directories;
-with GNAT.Heap_Sort_G;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with GNAT.Table;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
package body GNAT.Perfect_Hash_Generators is
- -- We are using the algorithm of J. Czech as described in Zbigniew J.
- -- Czech, George Havas, and Bohdan S. Majewski ``An Optimal Algorithm for
- -- Generating Minimal Perfect Hash Functions'', Information Processing
- -- Letters, 43(1992) pp.257-264, Oct.1992
-
- -- This minimal perfect hash function generator is based on random graphs
- -- and produces a hash function of the form:
-
- -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
-
- -- where f1 and f2 are functions that map strings into integers, and g is
- -- a function that maps integers into [0, m-1]. h can be order preserving.
- -- For instance, let W = {w_0, ..., w_i, ..., w_m-1}, h can be defined
- -- such that h (w_i) = i.
-
- -- This algorithm defines two possible constructions of f1 and f2. Method
- -- b) stores the hash function in less memory space at the expense of
- -- greater CPU time.
-
- -- a) fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n
-
- -- size (Tk) = max (for w in W) (length (w)) * size (used char set)
-
- -- b) fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n
-
- -- size (Tk) = max (for w in W) (length (w)) but the table lookups are
- -- replaced by multiplications.
-
- -- where Tk values are randomly generated. n is defined later on but the
- -- algorithm recommends to use a value a little bit greater than 2m. Note
- -- that for large values of m, the main memory space requirements comes
- -- from the memory space for storing function g (>= 2m entries).
-
- -- Random graphs are frequently used to solve difficult problems that do
- -- not have polynomial solutions. This algorithm is based on a weighted
- -- undirected graph. It comprises two steps: mapping and assignment.
-
- -- In the mapping step, a graph G = (V, E) is constructed, where = {0, 1,
- -- ..., n-1} and E = {(for w in W) (f1 (w), f2 (w))}. In order for the
- -- assignment step to be successful, G has to be acyclic. To have a high
- -- probability of generating an acyclic graph, n >= 2m. If it is not
- -- acyclic, Tk have to be regenerated.
-
- -- In the assignment step, the algorithm builds function g. As G is
- -- acyclic, there is a vertex v1 with only one neighbor v2. Let w_i be
- -- the word such that v1 = f1 (w_i) and v2 = f2 (w_i). Let g (v1) = 0 by
- -- construction and g (v2) = (i - g (v1)) mod n (or h (i) - g (v1) mod n).
- -- If word w_j is such that v2 = f1 (w_j) and v3 = f2 (w_j), g (v3) = (j -
- -- g (v2)) mod (or to be general, (h (j) - g (v2)) mod n). If w_i has no
- -- neighbor, then another vertex is selected. The algorithm traverses G to
- -- assign values to all the vertices. It cannot assign a value to an
- -- already assigned vertex as G is acyclic.
-
- subtype Word_Id is Integer;
- subtype Key_Id is Integer;
- subtype Vertex_Id is Integer;
- subtype Edge_Id is Integer;
- subtype Table_Id is Integer;
-
- No_Vertex : constant Vertex_Id := -1;
- No_Edge : constant Edge_Id := -1;
- No_Table : constant Table_Id := -1;
-
- type Word_Type is new String_Access;
- 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);
- -- Resize string W to have a length Len
-
- type Key_Type is record
- Edge : Edge_Id;
- end record;
- -- A key corresponds to an edge in the algorithm graph
-
- type Vertex_Type is record
- First : Edge_Id;
- Last : Edge_Id;
- end record;
- -- A vertex can be involved in several edges. First and Last are the bounds
- -- of an array of edges stored in a global edge table.
-
- type Edge_Type is record
- X : Vertex_Id;
- Y : Vertex_Id;
- Key : Key_Id;
- end record;
- -- An edge is a peer of vertices. In the algorithm, a key is associated to
- -- an edge.
-
- package WT is new GNAT.Table (Word_Type, Word_Id, 0, 32, 32);
- package IT is new GNAT.Table (Integer, Integer, 0, 32, 32);
- -- The two main tables. WT is used to store the words in their initial
- -- version and in their reduced version (that is words reduced to their
- -- significant characters). As an instance of GNAT.Table, WT does not
- -- initialize string pointers to null. This initialization has to be done
- -- manually when the table is allocated. IT is used to store several
- -- tables of components containing only integers.
+ use SPHG;
function Image (Int : Integer; W : Natural := 0) return String;
function Image (Str : String; W : Natural := 0) return String;
-- 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
-
EOL : constant Character := ASCII.LF;
Max : constant := 78;
Line : String (1 .. Max);
-- Use this line to provide buffered IO
+ NK : Natural := 0;
+ -- NK : Number of Keys
+
+ Opt : Optimization;
+ -- Optimization mode (memory vs CPU)
+
procedure Add (C : Character);
procedure Add (S : String);
-- Add a character or a string in Line and update Last
procedure Put (File : File_Descriptor; Str : String);
-- Simulate Ada.Text_IO.Put with GNAT.OS_Lib
- procedure Put_Used_Char_Set (File : File_Descriptor; Title : String);
- -- Output a title and a used character set
-
- procedure Put_Int_Vector
- (File : File_Descriptor;
- Title : String;
- Vector : Integer;
- Length : Natural);
- -- Output a title and a vector
-
procedure Put_Int_Matrix
(File : File_Descriptor;
Title : String;
- Table : Table_Id;
+ Table : Table_Name;
Len_1 : Natural;
Len_2 : Natural);
-- Output a title and a matrix. When the matrix has only one non-empty
-- dimension (Len_2 = 0), output a vector.
- procedure Put_Edges (File : File_Descriptor; Title : String);
- -- Output a title and an edge table
-
- procedure Put_Initial_Keys (File : File_Descriptor; Title : String);
- -- Output a title and a key table
-
- procedure Put_Reduced_Keys (File : File_Descriptor; Title : String);
- -- Output a title and a key table
-
- procedure Put_Vertex_Table (File : File_Descriptor; Title : String);
- -- Output a title and a vertex table
-
function Ada_File_Base_Name (Pkg_Name : String) return String;
-- Return the base file name (i.e. without .ads/.adb extension) for an
-- Ada source file containing the named package, using the standard GNAT
-- file-naming convention. For example, if Pkg_Name is "Parent.Child", we
-- return "parent-child".
- ----------------------------------
- -- Character Position Selection --
- ----------------------------------
-
- -- We reduce the maximum key size by selecting representative positions
- -- in these keys. We build a matrix with one word per line. We fill the
- -- remaining space of a line with ASCII.NUL. The heuristic selects the
- -- position that induces the minimum number of collisions. If there are
- -- collisions, select another position on the reduced key set responsible
- -- of the collisions. Apply the heuristic until there is no more collision.
-
- procedure Apply_Position_Selection;
- -- Apply Position selection and build the reduced key table
-
- procedure Parse_Position_Selection (Argument : String);
- -- Parse Argument and compute the position set. Argument is list of
- -- substrings separated by commas. Each substring represents a position
- -- or a range of positions (like x-y).
-
- procedure Select_Character_Set;
- -- Define an optimized used character set like Character'Pos in order not
- -- to allocate tables of 256 entries.
-
- procedure Select_Char_Position;
- -- Find a min char position set in order to reduce the max key length. The
- -- heuristic selects the position that induces the minimum number of
- -- collisions. If there are collisions, select another position on the
- -- reduced key set responsible of the collisions. Apply the heuristic until
- -- there is no collision.
-
- -----------------------------
- -- Random Graph Generation --
- -----------------------------
-
- procedure Random (Seed : in out Natural);
- -- Simulate Ada.Discrete_Numerics.Random
-
- procedure Generate_Mapping_Table
- (Tab : Table_Id;
- L1 : Natural;
- L2 : Natural;
- Seed : in out Natural);
- -- Random generation of the tables below. T is already allocated
-
- procedure Generate_Mapping_Tables
- (Opt : Optimization;
- Seed : in out Natural);
- -- Generate the mapping tables T1 and T2. They are used to define fk (w) =
- -- sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n. Keys, NK and Chars
- -- are used to compute the matrix size.
-
- ---------------------------
- -- Algorithm Computation --
- ---------------------------
-
- procedure Compute_Edges_And_Vertices (Opt : Optimization);
- -- Compute the edge and vertex tables. These are empty when a self loop is
- -- detected (f1 (w) = f2 (w)). The edge table is sorted by X value and then
- -- Y value. Keys is the key table and NK the number of keys. Chars is the
- -- set of characters really used in Keys. NV is the number of vertices
- -- recommended by the algorithm. T1 and T2 are the mapping tables needed to
- -- compute f1 (w) and f2 (w).
-
- function Acyclic return Boolean;
- -- Return True when the graph is acyclic. Vertices is the current vertex
- -- table and Edges the current edge table.
-
- procedure Assign_Values_To_Vertices;
- -- Execute the assignment step of the algorithm. Keys is the current key
- -- table. Vertices and Edges represent the random graph. G is the result of
- -- the assignment step such that:
- -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
-
- function Sum
- (Word : Word_Type;
- Table : Table_Id;
- Opt : Optimization) return Natural;
- -- For an optimization of CPU_Time return
- -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n
- -- For an optimization of Memory_Space return
- -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n
- -- Here NV = n
-
- -------------------------------
- -- Internal Table Management --
- -------------------------------
-
- function Allocate (N : Natural; S : Natural := 1) return Table_Id;
- -- Allocate N * S ints from IT table
-
- ----------
- -- Keys --
- ----------
-
- Keys : Table_Id := No_Table;
- NK : Natural := 0;
- -- NK : Number of Keys
-
- function Initial (K : Key_Id) return Word_Id;
- pragma Inline (Initial);
-
- function Reduced (K : Key_Id) return Word_Id;
- pragma Inline (Reduced);
-
- function Get_Key (N : Key_Id) return Key_Type;
- procedure Set_Key (N : Key_Id; Item : Key_Type);
- -- Get or Set Nth element of Keys table
-
- ------------------
- -- Char_Pos_Set --
- ------------------
-
- Char_Pos_Set : Table_Id := No_Table;
- Char_Pos_Set_Len : Natural;
- -- Character Selected Position Set
-
- function Get_Char_Pos (P : Natural) return Natural;
- procedure Set_Char_Pos (P : Natural; Item : Natural);
- -- Get or Set the string position of the Pth selected character
-
- -------------------
- -- Used_Char_Set --
- -------------------
-
- Used_Char_Set : Table_Id := No_Table;
- Used_Char_Set_Len : Natural;
- -- Used Character Set : Define a new character mapping. When all the
- -- characters are not present in the keys, in order to reduce the size
- -- of some tables, we redefine the character mapping.
-
- function Get_Used_Char (C : Character) return Natural;
- procedure Set_Used_Char (C : Character; Item : Natural);
-
- ------------
- -- Tables --
- ------------
-
- T1 : Table_Id := No_Table;
- T2 : Table_Id := No_Table;
- T1_Len : Natural;
- T2_Len : Natural;
- -- T1 : Values table to compute F1
- -- T2 : Values table to compute F2
-
- function Get_Table (T : Integer; X, Y : Natural) return Natural;
- procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural);
-
- -----------
- -- Graph --
- -----------
-
- G : Table_Id := No_Table;
- G_Len : Natural;
- -- Values table to compute G
-
- NT : Natural := Default_Tries;
- -- Number of tries running the algorithm before raising an error
-
- function Get_Graph (N : Natural) return Integer;
- procedure Set_Graph (N : Natural; Item : Integer);
- -- Get or Set Nth element of graph
-
- -----------
- -- Edges --
- -----------
-
- Edge_Size : constant := 3;
- Edges : Table_Id := No_Table;
- Edges_Len : Natural;
- -- Edges : Edge table of the random graph G
-
- function Get_Edges (F : Natural) return Edge_Type;
- procedure Set_Edges (F : Natural; Item : Edge_Type);
-
- --------------
- -- Vertices --
- --------------
-
- Vertex_Size : constant := 2;
-
- Vertices : Table_Id := No_Table;
- -- Vertex table of the random graph G
-
- NV : Natural;
- -- Number of Vertices
-
- function Get_Vertices (F : Natural) return Vertex_Type;
- procedure Set_Vertices (F : Natural; Item : Vertex_Type);
- -- Comments needed ???
-
- K2V : Float;
- -- Ratio between Keys and Vertices (parameter of Czech's algorithm)
-
- Opt : Optimization;
- -- Optimization mode (memory vs CPU)
-
- Max_Key_Len : Natural := 0;
- Min_Key_Len : Natural := 0;
- -- Maximum and minimum of all the word length
-
- S : Natural;
- -- Seed
-
- function Type_Size (L : Natural) return Natural;
- -- Given the last L of an unsigned integer type T, return its size
-
- -------------
- -- Acyclic --
- -------------
-
- function Acyclic return Boolean is
- Marks : array (0 .. NV - 1) of Vertex_Id := (others => No_Vertex);
-
- function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean;
- -- Propagate Mark from X to Y. X is already marked. Mark Y and propagate
- -- it to the edges of Y except the one representing the same key. Return
- -- False when Y is marked with Mark.
-
- --------------
- -- Traverse --
- --------------
-
- function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean is
- E : constant Edge_Type := Get_Edges (Edge);
- K : constant Key_Id := E.Key;
- Y : constant Vertex_Id := E.Y;
- M : constant Vertex_Id := Marks (E.Y);
- V : Vertex_Type;
-
- begin
- if M = Mark then
- return False;
-
- elsif M = No_Vertex then
- Marks (Y) := Mark;
- V := Get_Vertices (Y);
-
- for J in V.First .. V.Last loop
-
- -- Do not propagate to the edge representing the same key
-
- if Get_Edges (J).Key /= K
- and then not Traverse (J, Mark)
- then
- return False;
- end if;
- end loop;
- end if;
-
- return True;
- end Traverse;
-
- Edge : Edge_Type;
-
- -- Start of processing for Acyclic
-
- begin
- -- Edges valid range is
-
- for J in 1 .. Edges_Len - 1 loop
-
- Edge := Get_Edges (J);
-
- -- Mark X of E when it has not been already done
-
- if Marks (Edge.X) = No_Vertex then
- Marks (Edge.X) := Edge.X;
- end if;
-
- -- Traverse E when this has not already been done
-
- if Marks (Edge.Y) = No_Vertex
- and then not Traverse (J, Edge.X)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Acyclic;
-
------------------------
-- Ada_File_Base_Name --
------------------------
Last := Last + Len;
end Add;
- --------------
- -- Allocate --
- --------------
-
- 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;
-
- ------------------------------
- -- Apply_Position_Selection --
- ------------------------------
-
- procedure Apply_Position_Selection is
- begin
- for J in 0 .. NK - 1 loop
- declare
- IW : constant String := WT.Table (Initial (J)).all;
- RW : String (1 .. IW'Length) := (others => ASCII.NUL);
- N : Natural := IW'First - 1;
-
- begin
- -- Select the characters of Word included in the position
- -- selection.
-
- for C in 0 .. Char_Pos_Set_Len - 1 loop
- exit when IW (Get_Char_Pos (C)) = ASCII.NUL;
- N := N + 1;
- RW (N) := IW (Get_Char_Pos (C));
- end loop;
-
- -- Build the new table with the reduced word. Be careful
- -- to deallocate the old version to avoid memory leaks.
-
- Free_Word (WT.Table (Reduced (J)));
- WT.Table (Reduced (J)) := New_Word (RW);
- Set_Key (J, (Edge => No_Edge));
- end;
- end loop;
- end Apply_Position_Selection;
-
- -------------------------------
- -- Assign_Values_To_Vertices --
- -------------------------------
-
- procedure Assign_Values_To_Vertices is
- X : Vertex_Id;
-
- procedure Assign (X : Vertex_Id);
- -- Execute assignment on X's neighbors except the vertex that we are
- -- coming from which is already assigned.
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign (X : Vertex_Id) is
- E : Edge_Type;
- V : constant Vertex_Type := Get_Vertices (X);
-
- begin
- for J in V.First .. V.Last loop
- E := Get_Edges (J);
-
- if Get_Graph (E.Y) = -1 then
- pragma Assert (NK /= 0);
- Set_Graph (E.Y, (E.Key - Get_Graph (X)) mod NK);
- Assign (E.Y);
- end if;
- end loop;
- end Assign;
-
- -- Start of processing for Assign_Values_To_Vertices
-
- begin
- -- Value -1 denotes an uninitialized value as it is supposed to
- -- be in the range 0 .. NK.
-
- if G = No_Table then
- G_Len := NV;
- G := Allocate (G_Len, 1);
- end if;
-
- for J in 0 .. G_Len - 1 loop
- Set_Graph (J, -1);
- end loop;
-
- for K in 0 .. NK - 1 loop
- X := Get_Edges (Get_Key (K).Edge).X;
-
- if Get_Graph (X) = -1 then
- Set_Graph (X, 0);
- Assign (X);
- end if;
- end loop;
-
- for J in 0 .. G_Len - 1 loop
- if Get_Graph (J) = -1 then
- Set_Graph (J, 0);
- end if;
- end loop;
-
- if Verbose then
- Put_Int_Vector (Output, "Assign Values To Vertices", G, G_Len);
- end if;
- end Assign_Values_To_Vertices;
-
-------------
-- Compute --
-------------
procedure Compute (Position : String := Default_Position) is
- Success : Boolean := False;
-
begin
- if NK = 0 then
- raise Program_Error with "keywords set cannot be empty";
- end if;
-
- if Verbose then
- Put_Initial_Keys (Output, "Initial Key Table");
- end if;
-
- if Position'Length /= 0 then
- Parse_Position_Selection (Position);
- else
- Select_Char_Position;
- end if;
-
- if Verbose then
- Put_Int_Vector
- (Output, "Char Position Set", Char_Pos_Set, Char_Pos_Set_Len);
- end if;
-
- Apply_Position_Selection;
-
- if Verbose then
- Put_Reduced_Keys (Output, "Reduced Keys Table");
- end if;
-
- Select_Character_Set;
-
- if Verbose then
- Put_Used_Char_Set (Output, "Character Position Table");
- end if;
-
- -- Perform Czech's algorithm
-
- for J in 1 .. NT loop
- Generate_Mapping_Tables (Opt, S);
- Compute_Edges_And_Vertices (Opt);
-
- -- When graph is not empty (no self-loop from previous operation) and
- -- not acyclic.
-
- if 0 < Edges_Len and then Acyclic then
- Success := True;
- exit;
- end if;
- end loop;
-
- if not Success then
- raise Too_Many_Tries;
- end if;
-
- Assign_Values_To_Vertices;
+ SPHG.Compute (Position);
end Compute;
- --------------------------------
- -- Compute_Edges_And_Vertices --
- --------------------------------
-
- procedure Compute_Edges_And_Vertices (Opt : Optimization) is
- X : Natural;
- Y : Natural;
- Key : Key_Type;
- Edge : Edge_Type;
- Vertex : Vertex_Type;
- Not_Acyclic : Boolean := False;
-
- procedure Move (From : Natural; To : Natural);
- function Lt (L, R : Natural) return Boolean;
- -- Subprograms needed for GNAT.Heap_Sort_G
-
- --------
- -- Lt --
- --------
-
- function Lt (L, R : Natural) return Boolean is
- EL : constant Edge_Type := Get_Edges (L);
- ER : constant Edge_Type := Get_Edges (R);
- begin
- return EL.X < ER.X or else (EL.X = ER.X and then EL.Y < ER.Y);
- end Lt;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (From : Natural; To : Natural) is
- begin
- Set_Edges (To, Get_Edges (From));
- end Move;
-
- package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
-
- -- Start of processing for Compute_Edges_And_Vertices
-
- begin
- -- We store edges from 1 to 2 * NK and leave zero alone in order to use
- -- GNAT.Heap_Sort_G.
-
- Edges_Len := 2 * NK + 1;
-
- if Edges = No_Table then
- Edges := Allocate (Edges_Len, Edge_Size);
- end if;
-
- if Vertices = No_Table then
- Vertices := Allocate (NV, Vertex_Size);
- end if;
-
- for J in 0 .. NV - 1 loop
- Set_Vertices (J, (No_Vertex, No_Vertex - 1));
- end loop;
-
- -- For each w, X = f1 (w) and Y = f2 (w)
-
- for J in 0 .. NK - 1 loop
- Key := Get_Key (J);
- Key.Edge := No_Edge;
- Set_Key (J, Key);
-
- X := Sum (WT.Table (Reduced (J)), T1, Opt);
- Y := Sum (WT.Table (Reduced (J)), T2, Opt);
-
- -- Discard T1 and T2 as soon as we discover a self loop
-
- if X = Y then
- Not_Acyclic := True;
- exit;
- end if;
-
- -- We store (X, Y) and (Y, X) to ease assignment step
-
- Set_Edges (2 * J + 1, (X, Y, J));
- Set_Edges (2 * J + 2, (Y, X, J));
- end loop;
-
- -- Return an empty graph when self loop detected
-
- if Not_Acyclic then
- Edges_Len := 0;
-
- else
- if Verbose then
- Put_Edges (Output, "Unsorted Edge Table");
- Put_Int_Matrix (Output, "Function Table 1", T1,
- T1_Len, T2_Len);
- Put_Int_Matrix (Output, "Function Table 2", T2,
- T1_Len, T2_Len);
- end if;
-
- -- Enforce consistency between edges and keys. Construct Vertices and
- -- compute the list of neighbors of a vertex First .. Last as Edges
- -- is sorted by X and then Y. To compute the neighbor list, sort the
- -- edges.
-
- Sorting.Sort (Edges_Len - 1);
-
- if Verbose then
- Put_Edges (Output, "Sorted Edge Table");
- Put_Int_Matrix (Output, "Function Table 1", T1,
- T1_Len, T2_Len);
- Put_Int_Matrix (Output, "Function Table 2", T2,
- T1_Len, T2_Len);
- end if;
-
- -- Edges valid range is 1 .. 2 * NK
-
- for E in 1 .. Edges_Len - 1 loop
- Edge := Get_Edges (E);
- Key := Get_Key (Edge.Key);
-
- if Key.Edge = No_Edge then
- Key.Edge := E;
- Set_Key (Edge.Key, Key);
- end if;
-
- Vertex := Get_Vertices (Edge.X);
-
- if Vertex.First = No_Edge then
- Vertex.First := E;
- end if;
-
- Vertex.Last := E;
- Set_Vertices (Edge.X, Vertex);
- end loop;
-
- if Verbose then
- Put_Reduced_Keys (Output, "Key Table");
- Put_Edges (Output, "Edge Table");
- Put_Vertex_Table (Output, "Vertex Table");
- end if;
- end if;
- end Compute_Edges_And_Vertices;
-
- ------------
- -- Define --
- ------------
-
- procedure Define
- (Name : Table_Name;
- Item_Size : out Natural;
- Length_1 : out Natural;
- Length_2 : out Natural)
- is
- begin
- case Name is
- when Character_Position =>
- Item_Size := 8;
- Length_1 := Char_Pos_Set_Len;
- Length_2 := 0;
-
- when Used_Character_Set =>
- Item_Size := 8;
- Length_1 := 256;
- Length_2 := 0;
-
- when Function_Table_1
- | Function_Table_2
- =>
- Item_Size := Type_Size (NV);
- Length_1 := T1_Len;
- Length_2 := T2_Len;
-
- when Graph_Table =>
- Item_Size := Type_Size (NK);
- Length_1 := NV;
- Length_2 := 0;
- end case;
- end Define;
-
--------------
-- Finalize --
--------------
procedure Finalize is
begin
- if Verbose then
- Put (Output, "Finalize");
- New_Line (Output);
- end if;
-
- -- Deallocate all the WT components (both initial and reduced ones) to
- -- avoid memory leaks.
-
- for W in 0 .. WT.Last loop
-
- -- 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;
-
- -- Reset all variables for next usage
-
- Keys := No_Table;
-
- Char_Pos_Set := No_Table;
- Char_Pos_Set_Len := 0;
-
- Used_Char_Set := No_Table;
- Used_Char_Set_Len := 0;
-
- T1 := No_Table;
- T2 := No_Table;
-
- T1_Len := 0;
- T2_Len := 0;
-
- G := No_Table;
- G_Len := 0;
-
- Edges := No_Table;
- Edges_Len := 0;
-
- Vertices := No_Table;
- NV := 0;
-
NK := 0;
- Max_Key_Len := 0;
- Min_Key_Len := 0;
+ SPHG.Finalize;
end Finalize;
- ----------------------------
- -- Generate_Mapping_Table --
- ----------------------------
-
- procedure Generate_Mapping_Table
- (Tab : Integer;
- L1 : Natural;
- L2 : Natural;
- Seed : in out Natural)
- is
- begin
- for J in 0 .. L1 - 1 loop
- for K in 0 .. L2 - 1 loop
- Random (Seed);
- Set_Table (Tab, J, K, Seed mod NV);
- end loop;
- end loop;
- end Generate_Mapping_Table;
-
- -----------------------------
- -- Generate_Mapping_Tables --
- -----------------------------
-
- procedure Generate_Mapping_Tables
- (Opt : Optimization;
- Seed : in out Natural)
- is
- begin
- -- If T1 and T2 are already allocated no need to do it twice. Reuse them
- -- as their size has not changed.
-
- if T1 = No_Table and then T2 = No_Table then
- declare
- Used_Char_Last : Natural := 0;
- Used_Char : Natural;
-
- begin
- if Opt = CPU_Time then
- for P in reverse Character'Range loop
- Used_Char := Get_Used_Char (P);
- if Used_Char /= 0 then
- Used_Char_Last := Used_Char;
- exit;
- end if;
- end loop;
- end if;
-
- T1_Len := Char_Pos_Set_Len;
- T2_Len := Used_Char_Last + 1;
- T1 := Allocate (T1_Len * T2_Len);
- T2 := Allocate (T1_Len * T2_Len);
- end;
- end if;
-
- Generate_Mapping_Table (T1, T1_Len, T2_Len, Seed);
- Generate_Mapping_Table (T2, T1_Len, T2_Len, Seed);
-
- if Verbose then
- Put_Used_Char_Set (Output, "Used Character Set");
- Put_Int_Matrix (Output, "Function Table 1", T1,
- T1_Len, T2_Len);
- Put_Int_Matrix (Output, "Function Table 2", T2,
- T1_Len, T2_Len);
- end if;
- end Generate_Mapping_Tables;
-
- ------------------
- -- Get_Char_Pos --
- ------------------
-
- function Get_Char_Pos (P : Natural) return Natural is
- N : constant Natural := Char_Pos_Set + P;
- begin
- return IT.Table (N);
- end Get_Char_Pos;
-
- ---------------
- -- Get_Edges --
- ---------------
-
- function Get_Edges (F : Natural) return Edge_Type is
- N : constant Natural := Edges + (F * Edge_Size);
- E : Edge_Type;
- begin
- E.X := IT.Table (N);
- E.Y := IT.Table (N + 1);
- E.Key := IT.Table (N + 2);
- return E;
- end Get_Edges;
-
- ---------------
- -- Get_Graph --
- ---------------
-
- function Get_Graph (N : Natural) return Integer is
- begin
- return IT.Table (G + N);
- end Get_Graph;
-
- -------------
- -- Get_Key --
- -------------
-
- function Get_Key (N : Key_Id) return Key_Type is
- K : Key_Type;
- begin
- K.Edge := IT.Table (Keys + N);
- return K;
- end Get_Key;
-
- ---------------
- -- Get_Table --
- ---------------
-
- function Get_Table (T : Integer; X, Y : Natural) return Natural is
- N : constant Natural := T + (Y * T1_Len) + X;
- begin
- return IT.Table (N);
- end Get_Table;
-
- -------------------
- -- Get_Used_Char --
- -------------------
-
- function Get_Used_Char (C : Character) return Natural is
- N : constant Natural := Used_Char_Set + Character'Pos (C);
- begin
- return IT.Table (N);
- end Get_Used_Char;
-
- ------------------
- -- Get_Vertices --
- ------------------
-
- function Get_Vertices (F : Natural) return Vertex_Type is
- N : constant Natural := Vertices + (F * Vertex_Size);
- V : Vertex_Type;
- begin
- V.First := IT.Table (N);
- V.Last := IT.Table (N + 1);
- return V;
- end Get_Vertices;
-
-----------
-- Image --
-----------
end;
end Image;
- -------------
- -- Initial --
- -------------
-
- function Initial (K : Key_Id) return Word_Id is
- begin
- return K;
- end Initial;
-
----------------
-- Initialize --
----------------
Optim : Optimization := Memory_Space;
Tries : Positive := Default_Tries)
is
- begin
- if Verbose then
- Put (Output, "Initialize");
- New_Line (Output);
- end if;
-
- -- Deallocate the part of the table concerning the reduced words.
- -- Initial words are already present in the table. We may have reduced
- -- words already there because a previous computation failed. We are
- -- currently retrying and the reduced words have to be deallocated.
-
- for W in Reduced (0) .. WT.Last loop
- Free_Word (WT.Table (W));
- end loop;
-
- IT.Init;
-
- -- Initialize of computation variables
-
- Keys := No_Table;
+ V : constant Positive := Positive (Float (NK) * K_To_V);
- Char_Pos_Set := No_Table;
- Char_Pos_Set_Len := 0;
-
- Used_Char_Set := No_Table;
- Used_Char_Set_Len := 0;
-
- T1 := No_Table;
- T2 := No_Table;
-
- T1_Len := 0;
- T2_Len := 0;
-
- G := No_Table;
- G_Len := 0;
-
- Edges := No_Table;
- Edges_Len := 0;
-
- Vertices := No_Table;
- NV := 0;
-
- S := Seed;
- K2V := K_To_V;
- Opt := Optim;
- NT := Tries;
-
- if K2V <= 2.0 then
- raise Program_Error with "K to V ratio cannot be lower than 2.0";
- end if;
-
- -- Do not accept a value of K2V too close to 2.0 such that once
- -- rounded up, NV = 2 * NK because the algorithm would not converge.
-
- NV := Natural (Float (NK) * K2V);
- if NV <= 2 * NK then
- NV := 2 * NK + 1;
- end if;
-
- Keys := Allocate (NK);
-
- -- Resize initial words to have all of them at the same size
- -- (so the size of the largest one).
-
- for K in 0 .. NK - 1 loop
- Resize_Word (WT.Table (Initial (K)), Max_Key_Len);
- end loop;
-
- -- Allocated the table to store the reduced words. As WT is a
- -- GNAT.Table (using C memory management), pointers have to be
- -- 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;
+ begin
+ Opt := Optim;
+ SPHG.Initialize (Seed, V, SPHG.Optimization (Optim), Tries);
end Initialize;
------------
------------
procedure Insert (Value : String) is
- Len : constant Natural := Value'Length;
-
- begin
- if Verbose then
- Put (Output, "Inserting """ & Value & """");
- 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;
-
- if Max_Key_Len < Len then
- Max_Key_Len := Len;
- end if;
-
- if Min_Key_Len = 0 or else Len < Min_Key_Len then
- Min_Key_Len := Len;
- end if;
- end Insert;
-
- --------------
- -- New_Line --
- --------------
-
- procedure New_Line (File : File_Descriptor) is
- begin
- if Write (File, EOL'Address, 1) /= 1 then
- raise Program_Error;
- end if;
- end New_Line;
-
- --------------
- -- New_Word --
- --------------
-
- function New_Word (S : String) return Word_Type is
- begin
- return new String'(S);
- end New_Word;
-
- ------------------------------
- -- Parse_Position_Selection --
- ------------------------------
-
- procedure Parse_Position_Selection (Argument : String) is
- N : Natural := Argument'First;
- L : constant Natural := Argument'Last;
- M : constant Natural := Max_Key_Len;
-
- T : array (1 .. M) of Boolean := (others => False);
-
- function Parse_Index return Natural;
- -- Parse argument starting at index N to find an index
-
- -----------------
- -- Parse_Index --
- -----------------
-
- function Parse_Index return Natural is
- C : Character := Argument (N);
- V : Natural := 0;
-
- begin
- if C = '$' then
- N := N + 1;
- return M;
- end if;
-
- if C not in '0' .. '9' then
- raise Program_Error with "cannot read position argument";
- end if;
-
- while C in '0' .. '9' loop
- V := V * 10 + (Character'Pos (C) - Character'Pos ('0'));
- N := N + 1;
- exit when L < N;
- C := Argument (N);
- end loop;
-
- return V;
- end Parse_Index;
-
- -- Start of processing for Parse_Position_Selection
-
- begin
- -- Empty specification means all the positions
-
- if L < N then
- Char_Pos_Set_Len := M;
- Char_Pos_Set := Allocate (Char_Pos_Set_Len);
-
- for C in 0 .. Char_Pos_Set_Len - 1 loop
- Set_Char_Pos (C, C + 1);
- end loop;
-
- else
- loop
- declare
- First, Last : Natural;
-
- begin
- First := Parse_Index;
- Last := First;
-
- -- Detect a range
-
- if N <= L and then Argument (N) = '-' then
- N := N + 1;
- Last := Parse_Index;
- end if;
-
- -- Include the positions in the selection
-
- for J in First .. Last loop
- T (J) := True;
- end loop;
- end;
-
- exit when L < N;
-
- if Argument (N) /= ',' then
- raise Program_Error with "cannot read position argument";
- end if;
-
- N := N + 1;
- end loop;
-
- -- Compute position selection length
-
- N := 0;
- for J in T'Range loop
- if T (J) then
- N := N + 1;
- end if;
- end loop;
-
- -- Fill position selection
+ begin
+ NK := NK + 1;
+ SPHG.Insert (Value);
+ end Insert;
- Char_Pos_Set_Len := N;
- Char_Pos_Set := Allocate (Char_Pos_Set_Len);
+ --------------
+ -- New_Line --
+ --------------
- N := 0;
- for J in T'Range loop
- if T (J) then
- Set_Char_Pos (N, J);
- N := N + 1;
- end if;
- end loop;
+ procedure New_Line (File : File_Descriptor) is
+ begin
+ if Write (File, EOL'Address, 1) /= 1 then
+ raise Program_Error;
end if;
- end Parse_Position_Selection;
+ end New_Line;
-------------
-- Produce --
is
File : File_Descriptor := Standout;
+ Siz, L1, L2 : Natural;
+ -- For calls to Define
+
Status : Boolean;
-- For call to Close
function Range_Img (F, L : Natural; T : String := "") return String;
-- Return string "[T range ]F .. L"
- function Type_Img (L : Natural) return String;
- -- Return the larger unsigned type T such that T'Last < L
+ function Type_Img (Siz : Positive) return String;
+ -- Return the name of the unsigned type of size S
---------------
-- Array_Img --
-- Type_Img --
--------------
- function Type_Img (L : Natural) return String is
- S : constant String := Image (Type_Size (L));
+ function Type_Img (Siz : Positive) return String is
+ S : constant String := Image (Siz);
U : String := "Unsigned_ ";
N : Natural := 9;
return U (1 .. N);
end Type_Img;
- F : Natural;
- L : Natural;
P : Natural;
FName : String := Ada_File_Base_Name (Pkg_Name) & ".ads";
-- Start of processing for Produce
begin
-
- if Verbose and then not Use_Stdout then
- Put (Output,
- "Producing " & Ada.Directories.Current_Directory & "/" & FName);
- New_Line (Output);
- end if;
-
if not Use_Stdout then
File := Create_File (FName, Binary);
New_Line (File);
if Opt = CPU_Time then
- Put (File, Array_Img ("C", Type_Img (256), "Character"));
- New_Line (File);
+ -- The format of this table is fixed
- F := Character'Pos (Character'First);
- L := Character'Pos (Character'Last);
+ Define (Used_Character_Set, Siz, L1, L2);
+ pragma Assert (L1 = 256 and then L2 = 0);
+
+ Put (File, Array_Img ("C", Type_Img (Siz), "Character"));
+ New_Line (File);
- for J in Character'Range loop
- P := Get_Used_Char (J);
- Put (File, Image (P), 1, 0, 1, F, L, Character'Pos (J));
+ for J in 0 .. 255 loop
+ P := Value (Used_Character_Set, J);
+ Put (File, Image (P), 1, 0, 1, 0, 255, J);
end loop;
New_Line (File);
end if;
- F := 0;
- L := Char_Pos_Set_Len - 1;
+ Define (Character_Position, Siz, L1, L2);
+ pragma Assert (Siz = 31 and then L2 = 0);
- Put (File, Array_Img ("P", "Natural", Range_Img (F, L)));
+ Put (File, Array_Img ("P", "Natural", Range_Img (0, L1 - 1)));
New_Line (File);
- for J in F .. L loop
- Put (File, Image (Get_Char_Pos (J)), 1, 0, 1, F, L, J);
+ for J in 0 .. L1 - 1 loop
+ P := Value (Character_Position, J);
+ Put (File, Image (P), 1, 0, 1, 0, L1 - 1, J);
end loop;
New_Line (File);
+ Define (Function_Table_1, Siz, L1, L2);
+
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);
+ Array_Img ("T1", Type_Img (Siz),
+ Range_Img (0, L1 - 1),
+ Range_Img (0, L2 - 1, Type_Img (8))),
+ Function_Table_1, L1, L2);
when Memory_Space =>
Put_Int_Matrix
(File,
- Array_Img ("T1", Type_Img (NV),
- Range_Img (0, T1_Len - 1)),
- T1, T1_Len, 0);
+ Array_Img ("T1", Type_Img (Siz),
+ Range_Img (0, L1 - 1)),
+ Function_Table_1, L1, 0);
end case;
New_Line (File);
+ Define (Function_Table_2, Siz, L1, L2);
+
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);
+ Array_Img ("T2", Type_Img (Siz),
+ Range_Img (0, L1 - 1),
+ Range_Img (0, L2 - 1, Type_Img (8))),
+ Function_Table_2, L1, L2);
when Memory_Space =>
Put_Int_Matrix
(File,
- Array_Img ("T2", Type_Img (NV),
- Range_Img (0, T1_Len - 1)),
- T2, T1_Len, 0);
+ Array_Img ("T2", Type_Img (Siz),
+ Range_Img (0, L1 - 1)),
+ Function_Table_2, L1, 0);
end case;
New_Line (File);
- Put_Int_Vector
- (File,
- Array_Img ("G", Type_Img (NK),
- Range_Img (0, G_Len - 1)),
- G, G_Len);
+ Define (Graph_Table, Siz, L1, L2);
+ pragma Assert (L2 = 0);
+
+ Put (File, Array_Img ("G", Type_Img (Siz),
+ Range_Img (0, L1 - 1)));
+ New_Line (File);
+
+ for J in 0 .. L1 - 1 loop
+ P := Value (Graph_Table, J);
+ Put (File, Image (P), 1, 0, 1, 0, L1 - 1, J);
+ end loop;
+
New_Line (File);
Put (File, " function Hash (S : String) return Natural is");
case Opt is
when CPU_Time =>
- Put (File, Type_Img (256));
+ Put (File, Type_Img (8));
when Memory_Space =>
Put (File, "Natural");
end if;
Put (File, ") mod ");
- Put (File, Image (NV));
+ Put (File, Image (L1));
Put (File, ";");
New_Line (File);
end if;
Put (File, ") mod ");
- Put (File, Image (NV));
+ Put (File, Image (L1));
Put (File, ";");
New_Line (File);
end if;
end Put;
- ---------------
- -- Put_Edges --
- ---------------
-
- procedure Put_Edges (File : File_Descriptor; Title : String) is
- E : Edge_Type;
- F1 : constant Natural := 1;
- L1 : constant Natural := Edges_Len - 1;
- M : constant Natural := Max / 5;
-
- begin
- Put (File, Title);
- New_Line (File);
-
- -- Edges valid range is 1 .. Edge_Len - 1
-
- for J in F1 .. L1 loop
- E := Get_Edges (J);
- Put (File, Image (J, M), F1, L1, J, 1, 4, 1);
- Put (File, Image (E.X, M), F1, L1, J, 1, 4, 2);
- Put (File, Image (E.Y, M), F1, L1, J, 1, 4, 3);
- Put (File, Image (E.Key, M), F1, L1, J, 1, 4, 4);
- end loop;
- end Put_Edges;
-
- ----------------------
- -- Put_Initial_Keys --
- ----------------------
-
- procedure Put_Initial_Keys (File : File_Descriptor; Title : String) is
- F1 : constant Natural := 0;
- L1 : constant Natural := NK - 1;
- M : constant Natural := Max / 5;
- K : Key_Type;
-
- begin
- Put (File, Title);
- New_Line (File);
-
- for J in F1 .. L1 loop
- 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, Trim_Trailing_Nuls (WT.Table (Initial (J)).all),
- F1, L1, J, 1, 3, 3);
- end loop;
- end Put_Initial_Keys;
-
--------------------
-- Put_Int_Matrix --
--------------------
procedure Put_Int_Matrix
(File : File_Descriptor;
Title : String;
- Table : Integer;
+ Table : Table_Name;
Len_1 : Natural;
Len_2 : Natural)
is
if Len_2 = 0 then
for J in F1 .. L1 loop
- Ix := IT.Table (Table + J);
+ Ix := Value (Table, J, 0);
Put (File, Image (Ix), 1, 0, 1, F1, L1, J);
end loop;
else
for J in F1 .. L1 loop
for K in F2 .. L2 loop
- Ix := IT.Table (Table + J + K * Len_1);
+ Ix := Value (Table, J, K);
Put (File, Image (Ix), F1, L1, J, F2, L2, K);
end loop;
end loop;
end if;
end Put_Int_Matrix;
- --------------------
- -- Put_Int_Vector --
- --------------------
-
- procedure Put_Int_Vector
- (File : File_Descriptor;
- Title : String;
- Vector : Integer;
- Length : Natural)
- is
- F2 : constant Natural := 0;
- L2 : constant Natural := Length - 1;
-
- begin
- Put (File, Title);
- New_Line (File);
-
- for J in F2 .. L2 loop
- Put (File, Image (IT.Table (Vector + J)), 1, 0, 1, F2, L2, J);
- end loop;
- end Put_Int_Vector;
-
- ----------------------
- -- Put_Reduced_Keys --
- ----------------------
-
- procedure Put_Reduced_Keys (File : File_Descriptor; Title : String) is
- F1 : constant Natural := 0;
- L1 : constant Natural := NK - 1;
- M : constant Natural := Max / 5;
- K : Key_Type;
-
- begin
- Put (File, Title);
- New_Line (File);
-
- for J in F1 .. L1 loop
- 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, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all),
- F1, L1, J, 1, 3, 3);
- end loop;
- end Put_Reduced_Keys;
-
- -----------------------
- -- Put_Used_Char_Set --
- -----------------------
-
- procedure Put_Used_Char_Set (File : File_Descriptor; Title : String) is
- F : constant Natural := Character'Pos (Character'First);
- L : constant Natural := Character'Pos (Character'Last);
-
- begin
- Put (File, Title);
- New_Line (File);
-
- for J in Character'Range loop
- Put
- (File, Image (Get_Used_Char (J)), 1, 0, 1, F, L, Character'Pos (J));
- end loop;
- end Put_Used_Char_Set;
-
- ----------------------
- -- Put_Vertex_Table --
- ----------------------
-
- procedure Put_Vertex_Table (File : File_Descriptor; Title : String) is
- F1 : constant Natural := 0;
- L1 : constant Natural := NV - 1;
- M : constant Natural := Max / 4;
- V : Vertex_Type;
-
- begin
- Put (File, Title);
- New_Line (File);
-
- for J in F1 .. L1 loop
- V := Get_Vertices (J);
- Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
- Put (File, Image (V.First, M), F1, L1, J, 1, 3, 2);
- Put (File, Image (V.Last, M), F1, L1, J, 1, 3, 3);
- end loop;
- end Put_Vertex_Table;
-
- ------------
- -- Random --
- ------------
-
- procedure Random (Seed : in out Natural) is
-
- -- Park & Miller Standard Minimal using Schrage's algorithm to avoid
- -- overflow: Xn+1 = 16807 * Xn mod (2 ** 31 - 1)
-
- R : Natural;
- Q : Natural;
- X : Integer;
-
- begin
- R := Seed mod 127773;
- Q := Seed / 127773;
- X := 16807 * R - 2836 * Q;
-
- Seed := (if X < 0 then X + 2147483647 else X);
- end Random;
-
- -------------
- -- Reduced --
- -------------
-
- function Reduced (K : Key_Id) return Word_Id is
- begin
- return K + NK + 1;
- end Reduced;
-
- -----------------
- -- Resize_Word --
- -----------------
-
- procedure Resize_Word (W : in out Word_Type; Len : Natural) is
- S1 : constant String := W.all;
- S2 : String (1 .. Len) := (others => ASCII.NUL);
- L : constant Natural := S1'Length;
- begin
- if L /= Len then
- Free_Word (W);
- S2 (1 .. L) := S1;
- W := New_Word (S2);
- end if;
- end Resize_Word;
-
- --------------------------
- -- Select_Char_Position --
- --------------------------
-
- procedure Select_Char_Position is
-
- type Vertex_Table_Type is array (Natural range <>) of Vertex_Type;
-
- procedure Build_Identical_Keys_Sets
- (Table : in out Vertex_Table_Type;
- Last : in out Natural;
- Pos : Natural);
- -- Build a list of keys subsets that are identical with the current
- -- position selection plus Pos. Once this routine is called, reduced
- -- words are sorted by subsets and each item (First, Last) in Sets
- -- defines the range of identical keys.
- -- Need comment saying exactly what Last is ???
-
- function Count_Different_Keys
- (Table : Vertex_Table_Type;
- Last : Natural;
- Pos : Natural) return Natural;
- -- For each subset in Sets, count the number of different keys if we add
- -- Pos to the current position selection.
-
- Sel_Position : IT.Table_Type (1 .. Max_Key_Len);
- Last_Sel_Pos : Natural := 0;
- Max_Sel_Pos : Natural := 0;
-
- -------------------------------
- -- Build_Identical_Keys_Sets --
- -------------------------------
-
- procedure Build_Identical_Keys_Sets
- (Table : in out Vertex_Table_Type;
- Last : in out Natural;
- Pos : Natural)
- is
- S : constant Vertex_Table_Type := Table (Table'First .. Last);
- C : constant Natural := Pos;
- -- Shortcuts (why are these not renames ???)
-
- F : Integer;
- L : Integer;
- -- First and last words of a subset
-
- Offset : Natural;
- -- GNAT.Heap_Sort assumes that the first array index is 1. Offset
- -- defines the translation to operate.
-
- function Lt (L, R : Natural) return Boolean;
- procedure Move (From : Natural; To : Natural);
- -- Subprograms needed by GNAT.Heap_Sort_G
-
- --------
- -- Lt --
- --------
-
- function Lt (L, R : Natural) return Boolean is
- C : constant Natural := Pos;
- Left : Natural;
- Right : Natural;
-
- begin
- if L = 0 then
- Left := NK;
- Right := Offset + R;
- elsif R = 0 then
- Left := Offset + L;
- Right := NK;
- else
- Left := Offset + L;
- Right := Offset + R;
- end if;
-
- return WT.Table (Left)(C) < WT.Table (Right)(C);
- end Lt;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (From : Natural; To : Natural) is
- Target, Source : Natural;
-
- begin
- if From = 0 then
- Source := NK;
- Target := Offset + To;
- elsif To = 0 then
- Source := Offset + From;
- Target := NK;
- else
- Source := Offset + From;
- Target := Offset + To;
- end if;
-
- WT.Table (Target) := WT.Table (Source);
- WT.Table (Source) := null;
- end Move;
-
- package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
-
- -- Start of processing for Build_Identical_Key_Sets
-
- begin
- Last := 0;
-
- -- For each subset in S, extract the new subsets we have by adding C
- -- in the position selection.
-
- for J in S'Range loop
- pragma Annotate (CodePeer, Modified, S (J));
-
- if S (J).First = S (J).Last then
- F := S (J).First;
- L := S (J).Last;
- Last := Last + 1;
- Table (Last) := (F, L);
-
- else
- Offset := Reduced (S (J).First) - 1;
- Sorting.Sort (S (J).Last - S (J).First + 1);
-
- F := S (J).First;
- L := F;
- for N in S (J).First .. S (J).Last loop
-
- -- For the last item, close the last subset
-
- if N = S (J).Last then
- Last := Last + 1;
- Table (Last) := (F, N);
-
- -- Two contiguous words are identical when they have the
- -- same Cth character.
-
- elsif WT.Table (Reduced (N))(C) =
- WT.Table (Reduced (N + 1))(C)
- then
- L := N + 1;
-
- -- Find a new subset of identical keys. Store the current
- -- one and create a new subset.
-
- else
- Last := Last + 1;
- Table (Last) := (F, L);
- F := N + 1;
- L := F;
- end if;
- end loop;
- end if;
- end loop;
- end Build_Identical_Keys_Sets;
-
- --------------------------
- -- Count_Different_Keys --
- --------------------------
-
- function Count_Different_Keys
- (Table : Vertex_Table_Type;
- Last : Natural;
- Pos : Natural) return Natural
- is
- N : array (Character) of Natural;
- C : Character;
- T : Natural := 0;
-
- begin
- -- For each subset, count the number of words that are still
- -- different when we include Pos in the position selection. Only
- -- focus on this position as the other positions already produce
- -- identical keys.
-
- for S in 1 .. Last loop
-
- -- Count the occurrences of the different characters
-
- N := (others => 0);
- for K in Table (S).First .. Table (S).Last loop
- C := WT.Table (Reduced (K))(Pos);
- N (C) := N (C) + 1;
- end loop;
-
- -- Update the number of different keys. Each character used
- -- denotes a different key.
-
- for J in N'Range loop
- if N (J) > 0 then
- T := T + 1;
- end if;
- end loop;
- end loop;
-
- return T;
- end Count_Different_Keys;
-
- -- Start of processing for Select_Char_Position
-
- begin
- -- Initialize the reduced words set
-
- for K in 0 .. NK - 1 loop
- WT.Table (Reduced (K)) := New_Word (WT.Table (Initial (K)).all);
- end loop;
-
- declare
- Differences : Natural;
- Max_Differences : Natural := 0;
- Old_Differences : Natural;
- Max_Diff_Sel_Pos : Natural := 0; -- init to kill warning
- Max_Diff_Sel_Pos_Idx : Natural := 0; -- init to kill warning
- Same_Keys_Sets_Table : Vertex_Table_Type (1 .. NK);
- Same_Keys_Sets_Last : Natural := 1;
-
- begin
- for C in Sel_Position'Range loop
- Sel_Position (C) := C;
- end loop;
-
- Same_Keys_Sets_Table (1) := (0, NK - 1);
-
- loop
- -- Preserve maximum number of different keys and check later on
- -- that this value is strictly incrementing. Otherwise, it means
- -- that two keys are strictly identical.
-
- Old_Differences := Max_Differences;
-
- -- The first position should not exceed the minimum key length.
- -- Otherwise, we may end up with an empty word once reduced.
-
- Max_Sel_Pos :=
- (if Last_Sel_Pos = 0 then Min_Key_Len else Max_Key_Len);
-
- -- Find which position increases more the number of differences
-
- for J in Last_Sel_Pos + 1 .. Max_Sel_Pos loop
- Differences := Count_Different_Keys
- (Same_Keys_Sets_Table,
- Same_Keys_Sets_Last,
- Sel_Position (J));
-
- if Verbose then
- Put (Output,
- "Selecting position" & Sel_Position (J)'Img &
- " results in" & Differences'Img &
- " differences");
- New_Line (Output);
- end if;
-
- if Differences > Max_Differences then
- Max_Differences := Differences;
- Max_Diff_Sel_Pos := Sel_Position (J);
- Max_Diff_Sel_Pos_Idx := J;
- end if;
- end loop;
-
- if Old_Differences = Max_Differences then
- raise Program_Error with "some keys are identical";
- end if;
-
- -- Insert selected position and sort Sel_Position table
-
- Last_Sel_Pos := Last_Sel_Pos + 1;
- Sel_Position (Last_Sel_Pos + 1 .. Max_Diff_Sel_Pos_Idx) :=
- Sel_Position (Last_Sel_Pos .. Max_Diff_Sel_Pos_Idx - 1);
- Sel_Position (Last_Sel_Pos) := Max_Diff_Sel_Pos;
-
- for P in 1 .. Last_Sel_Pos - 1 loop
- if Max_Diff_Sel_Pos < Sel_Position (P) then
- pragma Annotate
- (CodePeer, False_Positive,
- "test always false", "false positive?");
-
- Sel_Position (P + 1 .. Last_Sel_Pos) :=
- Sel_Position (P .. Last_Sel_Pos - 1);
- Sel_Position (P) := Max_Diff_Sel_Pos;
- exit;
- end if;
- end loop;
-
- exit when Max_Differences = NK;
-
- Build_Identical_Keys_Sets
- (Same_Keys_Sets_Table,
- Same_Keys_Sets_Last,
- Max_Diff_Sel_Pos);
-
- if Verbose then
- Put (Output,
- "Selecting position" & Max_Diff_Sel_Pos'Img &
- " results in" & Max_Differences'Img &
- " differences");
- New_Line (Output);
- Put (Output, "--");
- New_Line (Output);
- for J in 1 .. Same_Keys_Sets_Last loop
- for K in
- Same_Keys_Sets_Table (J).First ..
- Same_Keys_Sets_Table (J).Last
- loop
- Put (Output,
- Trim_Trailing_Nuls (WT.Table (Reduced (K)).all));
- New_Line (Output);
- end loop;
- Put (Output, "--");
- New_Line (Output);
- end loop;
- end if;
- end loop;
- end;
-
- Char_Pos_Set_Len := Last_Sel_Pos;
- Char_Pos_Set := Allocate (Char_Pos_Set_Len);
-
- for C in 1 .. Last_Sel_Pos loop
- Set_Char_Pos (C - 1, Sel_Position (C));
- end loop;
- end Select_Char_Position;
-
- --------------------------
- -- Select_Character_Set --
- --------------------------
-
- procedure Select_Character_Set is
- Last : Natural := 0;
- Used : array (Character) of Boolean := (others => False);
- Char : Character;
-
- begin
- for J in 0 .. NK - 1 loop
- for K in 0 .. Char_Pos_Set_Len - 1 loop
- Char := WT.Table (Initial (J))(Get_Char_Pos (K));
- exit when Char = ASCII.NUL;
- Used (Char) := True;
- end loop;
- end loop;
-
- Used_Char_Set_Len := 256;
- Used_Char_Set := Allocate (Used_Char_Set_Len);
-
- for J in Used'Range loop
- if Used (J) then
- Set_Used_Char (J, Last);
- Last := Last + 1;
- else
- Set_Used_Char (J, 0);
- end if;
- end loop;
- end Select_Character_Set;
-
- ------------------
- -- Set_Char_Pos --
- ------------------
-
- procedure Set_Char_Pos (P : Natural; Item : Natural) is
- N : constant Natural := Char_Pos_Set + P;
- begin
- IT.Table (N) := Item;
- end Set_Char_Pos;
-
- ---------------
- -- Set_Edges --
- ---------------
-
- procedure Set_Edges (F : Natural; Item : Edge_Type) is
- N : constant Natural := Edges + (F * Edge_Size);
- begin
- IT.Table (N) := Item.X;
- IT.Table (N + 1) := Item.Y;
- IT.Table (N + 2) := Item.Key;
- end Set_Edges;
-
- ---------------
- -- Set_Graph --
- ---------------
-
- procedure Set_Graph (N : Natural; Item : Integer) is
- begin
- IT.Table (G + N) := Item;
- end Set_Graph;
-
- -------------
- -- Set_Key --
- -------------
-
- procedure Set_Key (N : Key_Id; Item : Key_Type) is
- begin
- IT.Table (Keys + N) := Item.Edge;
- end Set_Key;
-
- ---------------
- -- Set_Table --
- ---------------
-
- procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural) is
- N : constant Natural := T + ((Y * T1_Len) + X);
- begin
- IT.Table (N) := Item;
- end Set_Table;
-
- -------------------
- -- Set_Used_Char --
- -------------------
-
- procedure Set_Used_Char (C : Character; Item : Natural) is
- N : constant Natural := Used_Char_Set + Character'Pos (C);
- begin
- IT.Table (N) := Item;
- end Set_Used_Char;
-
- ------------------
- -- Set_Vertices --
- ------------------
-
- procedure Set_Vertices (F : Natural; Item : Vertex_Type) is
- N : constant Natural := Vertices + (F * Vertex_Size);
- begin
- IT.Table (N) := Item.First;
- IT.Table (N + 1) := Item.Last;
- end Set_Vertices;
-
- ---------
- -- Sum --
- ---------
-
- function Sum
- (Word : Word_Type;
- Table : Table_Id;
- Opt : Optimization) return Natural
- is
- S : Natural := 0;
- R : Natural;
-
- begin
- 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)));
- pragma Assert (NV /= 0);
- S := (S + R) mod NV;
- end loop;
-
- when Memory_Space =>
- for J in 0 .. T1_Len - 1 loop
- exit when Word (J + 1) = ASCII.NUL;
- R := Get_Table (Table, J, 0);
- pragma Assert (NV /= 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 --
- ---------------
-
- function Type_Size (L : Natural) return Natural is
- begin
- if L <= 2 ** 8 then
- return 8;
- elsif L <= 2 ** 16 then
- return 16;
- else
- return 32;
- end if;
- end Type_Size;
-
- -----------
- -- Value --
- -----------
-
- function Value
- (Name : Table_Name;
- J : Natural;
- K : Natural := 0) return Natural
- is
- begin
- case Name is
- when Character_Position =>
- return Get_Char_Pos (J);
-
- when Used_Character_Set =>
- return Get_Used_Char (Character'Val (J));
-
- when Function_Table_1 =>
- return Get_Table (T1, J, K);
-
- when Function_Table_2 =>
- return Get_Table (T2, J, K);
-
- when Graph_Table =>
- return Get_Graph (J);
- end case;
- end Value;
-
end GNAT.Perfect_Hash_Generators;
-- < h (w2). These hashing functions are convenient for use with realtime
-- applications.
+with System.Perfect_Hash_Generators;
+
package GNAT.Perfect_Hash_Generators is
+ package SPHG renames System.Perfect_Hash_Generators;
+
Default_K_To_V : constant Float := 2.05;
-- Default ratio for the algorithm. When K is the number of keys, V =
-- (K_To_V) * K is the size of the main table of the hash function. To
-- try and may have to iterate a number of times. This constant bounds the
-- number of tries.
- type Optimization is (Memory_Space, CPU_Time);
+ type Optimization is new SPHG.Optimization;
-- Optimize either the memory space or the execution time. Note: in
-- practice, the optimization mode has little effect on speed. The tables
-- are somewhat smaller with Memory_Space.
- Verbose : Boolean := False;
+ Verbose : Boolean renames SPHG.Verbose;
-- Output the status of the algorithm. For instance, the tables, the random
-- graph (edges, vertices) and selected char positions are output between
-- two iterations.
-- the same words.
--
-- A classical way of doing is to Insert all the words and then to invoke
- -- Initialize and Compute. If Compute fails to find a perfect hash
- -- function, invoke Initialize another time with other configuration
- -- parameters (probably with a greater K_To_V ratio). Once successful,
- -- invoke Produce and Finalize.
+ -- Initialize and Compute. If this fails to find a perfect hash function,
+ -- invoke Initialize again with other configuration parameters (probably
+ -- with a greater K_To_V ratio). Once successful, invoke Produce and then
+ -- Finalize.
procedure Finalize;
-- Deallocate the internal structures and the words table
procedure Insert (Value : String);
-- Insert a new word into the table. ASCII.NUL characters are not allowed.
- Too_Many_Tries : exception;
+ Too_Many_Tries : exception renames SPHG.Too_Many_Tries;
-- Raised after Tries unsuccessful runs
procedure Compute (Position : String := Default_Position);
-- GNAT file name for a package named Pkg_Name. If Use_Stdout is True, the
-- output goes to standard output, and no files are written.
- ----------------------------------------------------------------
-
- -- The routines and structures defined below allow producing the hash
- -- function using a different way from the procedure above. The procedure
- -- Define returns the lengths of an internal table and its item type size.
- -- The function Value returns the value of each item in the table.
-
- -- The hash function has the following form:
-
- -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
-
- -- G is a function based on a graph table [0,n-1] -> [0,m-1]. m is the
- -- number of keys. n is an internally computed value and it can be obtained
- -- as the length of vector G.
-
- -- F1 and F2 are two functions based on two function tables T1 and T2.
- -- Their definition depends on the chosen optimization mode.
-
- -- Only some character positions are used in the words because they are
- -- significant. They are listed in a character position table (P in the
- -- pseudo-code below). For instance, in {"jan", "feb", "mar", "apr", "jun",
- -- "jul", "aug", "sep", "oct", "nov", "dec"}, only positions 2 and 3 are
- -- significant (the first character can be ignored). In this example, P =
- -- {2, 3}
-
- -- When Optimization is CPU_Time, the first dimension of T1 and T2
- -- corresponds to the character position in the word and the second to the
- -- character set. As all the character set is not used, we define a used
- -- character table which associates a distinct index to each used character
- -- (unused characters are mapped to zero). In this case, the second
- -- dimension of T1 and T2 is reduced to the used character set (C in the
- -- pseudo-code below). Therefore, the hash function has the following:
-
- -- function Hash (S : String) return Natural is
- -- F : constant Natural := S'First - 1;
- -- L : constant Natural := S'Length;
- -- F1, F2 : Natural := 0;
- -- J : <t>;
-
- -- begin
- -- for K in P'Range loop
- -- exit when L < P (K);
- -- J := C (S (P (K) + F));
- -- F1 := (F1 + Natural (T1 (K, J))) mod <n>;
- -- F2 := (F2 + Natural (T2 (K, J))) mod <n>;
- -- end loop;
-
- -- return (Natural (G (F1)) + Natural (G (F2))) mod <m>;
- -- end Hash;
-
- -- When Optimization is Memory_Space, the first dimension of T1 and T2
- -- corresponds to the character position in the word and the second
- -- dimension is ignored. T1 and T2 are no longer matrices but vectors.
- -- Therefore, the used character table is not available. The hash function
- -- has the following form:
-
- -- function Hash (S : String) return Natural is
- -- F : constant Natural := S'First - 1;
- -- L : constant Natural := S'Length;
- -- F1, F2 : Natural := 0;
- -- J : <t>;
-
- -- begin
- -- for K in P'Range loop
- -- exit when L < P (K);
- -- J := Character'Pos (S (P (K) + F));
- -- F1 := (F1 + Natural (T1 (K) * J)) mod <n>;
- -- F2 := (F2 + Natural (T2 (K) * J)) mod <n>;
- -- end loop;
-
- -- return (Natural (G (F1)) + Natural (G (F2))) mod <m>;
- -- end Hash;
-
- type Table_Name is
- (Character_Position,
- Used_Character_Set,
- Function_Table_1,
- Function_Table_2,
- Graph_Table);
-
- procedure Define
- (Name : Table_Name;
- Item_Size : out Natural;
- Length_1 : out Natural;
- Length_2 : out Natural);
- -- Return the definition of the table Name. This includes the length of
- -- dimensions 1 and 2 and the size of an unsigned integer item. When
- -- Length_2 is zero, the table has only one dimension. All the ranges
- -- start from zero.
-
- function Value
- (Name : Table_Name;
- J : Natural;
- K : Natural := 0) return Natural;
- -- Return the value of the component (I, J) of the table Name. When the
- -- table has only one dimension, J is ignored.
-
end GNAT.Perfect_Hash_Generators;
-- GNAT.Table
-- Table (the compiler unit)
+pragma Compiler_Unit_Warning;
+
with GNAT.Dynamic_Tables;
generic
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- S Y S T E M . I M G _ E N U M --
+-- S Y S T E M . I M A G E _ N --
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
+-- Copyright (C) 2021, 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- --
-- --
------------------------------------------------------------------------------
-pragma Compiler_Unit_Warning;
-
with Ada.Unchecked_Conversion;
-package body System.Img_Enum is
+package body System.Image_N is
- -------------------------
- -- Image_Enumeration_8 --
- -------------------------
+ -----------------------
+ -- Image_Enumeration --
+ -----------------------
- function Image_Enumeration_8
+ procedure Image_Enumeration
(Pos : Natural;
+ S : in out String;
+ P : out Natural;
Names : String;
Indexes : System.Address)
- return String
is
- type Natural_8 is range 0 .. 2 ** 7 - 1;
- type Index_Table is array (Natural) of Natural_8;
- type Index_Table_Ptr is access Index_Table;
-
- function To_Index_Table_Ptr is
- new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
-
- IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
-
- Start : constant Natural := Natural (IndexesT (Pos));
- Next : constant Natural := Natural (IndexesT (Pos + 1));
-
- subtype Result_Type is String (1 .. Next - Start);
- -- We need this result type to force the result to have the
- -- required lower bound of 1, rather than the slice bounds.
-
- begin
- return Result_Type (Names (Start .. Next - 1));
- end Image_Enumeration_8;
-
- --------------------------
- -- Image_Enumeration_16 --
- --------------------------
+ pragma Assert (S'First = 1);
- function Image_Enumeration_16
- (Pos : Natural;
- Names : String;
- Indexes : System.Address)
- return String
- is
- type Natural_16 is range 0 .. 2 ** 15 - 1;
- type Index_Table is array (Natural) of Natural_16;
+ subtype Names_Index is
+ Index_Type range Index_Type (Names'First)
+ .. Index_Type (Names'Last) + 1;
+ subtype Index is Natural range Natural'First .. Names'Length;
+ type Index_Table is array (Index) of Names_Index;
type Index_Table_Ptr is access Index_Table;
function To_Index_Table_Ptr is
IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
- Start : constant Natural := Natural (IndexesT (Pos));
- Next : constant Natural := Natural (IndexesT (Pos + 1));
-
- subtype Result_Type is String (1 .. Next - Start);
- -- We need this result type to force the result to have the
- -- required lower bound of 1, rather than the slice bounds.
-
- begin
- return Result_Type (Names (Start .. Next - 1));
- end Image_Enumeration_16;
-
- --------------------------
- -- Image_Enumeration_32 --
- --------------------------
-
- function Image_Enumeration_32
- (Pos : Natural;
- Names : String;
- Indexes : System.Address)
- return String
- is
- type Natural_32 is range 0 .. 2 ** 31 - 1;
- type Index_Table is array (Natural) of Natural_32;
- type Index_Table_Ptr is access Index_Table;
-
- function To_Index_Table_Ptr is
- new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
-
- IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
+ pragma Assert (Pos in IndexesT'Range);
+ pragma Assert (Pos + 1 in IndexesT'Range);
Start : constant Natural := Natural (IndexesT (Pos));
Next : constant Natural := Natural (IndexesT (Pos + 1));
- subtype Result_Type is String (1 .. Next - Start);
- -- We need this result type to force the result to have the
- -- required lower bound of 1, rather than the slice bounds.
+ pragma Assert (Next - 1 >= Start);
+ pragma Assert (Start >= Names'First);
+ pragma Assert (Next - 1 <= Names'Last);
+ pragma Assert (Next - Start <= S'Last);
+ -- The caller should guarantee that S is large enough to contain the
+ -- enumeration image.
begin
- return Result_Type (Names (Start .. Next - 1));
- end Image_Enumeration_32;
+ S (1 .. Next - Start) := Names (Start .. Next - 1);
+ P := Next - Start;
+ end Image_Enumeration;
-end System.Img_Enum;
+end System.Image_N;
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- S Y S T E M . I M G _ E N U M --
+-- S Y S T E M . I M A G E _ N --
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
+-- Copyright (C) 2021, 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- --
-- package System (where it is too early to start building image tables).
-- Special routines exist for the enumeration types in these packages.
--- Note: this is an obsolete package, replaced by System.Img_Enum_New, which
--- provides procedures instead of functions for these enumeration image calls.
--- The reason we maintain this package is that when bootstrapping with old
--- compilers, the old compiler will search for this unit, expecting to find
--- these functions. The new compiler will search for procedures in the new
--- version of the unit.
+generic
-pragma Compiler_Unit_Warning;
+ type Index_Type is range <>;
-package System.Img_Enum is
+package System.Image_N is
pragma Pure;
- function Image_Enumeration_8
+ procedure Image_Enumeration
(Pos : Natural;
+ S : in out String;
+ P : out Natural;
Names : String;
- Indexes : System.Address) return String;
+ Indexes : System.Address);
-- Used to compute Enum'Image (Str) where Enum is some enumeration type
- -- other than those defined in package Standard. Names is a string with a
- -- lower bound of 1 containing the characters of all the enumeration
- -- literals concatenated together in sequence. Indexes is the address of an
- -- array of type array (0 .. N) of Natural_8, where N is the number of
+ -- other than those defined in package Standard. Names is a string with
+ -- a lower bound of 1 containing the characters of all the enumeration
+ -- literals concatenated together in sequence. Indexes is the address of
+ -- an array of type array (0 .. N) of Index_Type, where N is the number of
-- enumeration literals in the type. The Indexes values are the starting
-- subscript of each enumeration literal, indexed by Pos values, with an
-- extra entry at the end containing Names'Length + 1. The reason that
-- Indexes is passed by address is that the actual type is created on the
- -- fly by the expander. The value returned is the desired 'Image value.
+ -- fly by the expander. The desired 'Image value is stored in S (1 .. P)
+ -- and P is set on return. The caller guarantees that S is long enough to
+ -- hold the result and that the lower bound is 1.
- function Image_Enumeration_16
- (Pos : Natural;
- Names : String;
- Indexes : System.Address) return String;
- -- Identical to Image_Enumeration_8 except that it handles types
- -- using array (0 .. Num) of Natural_16 for the Indexes table.
-
- function Image_Enumeration_32
- (Pos : Natural;
- Names : String;
- Indexes : System.Address) return String;
- -- Identical to Image_Enumeration_8 except that it handles types
- -- using array (0 .. Num) of Natural_32 for the Indexes table.
-
-end System.Img_Enum;
+end System.Image_N;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ E N U M _ 1 6 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Instantiation of System.Image_N for enumeration types whose names table
+-- has a length that fits in a 16-bit but not a 8-bit integer.
+
+with Interfaces;
+with System.Image_N;
+
+package System.Img_Enum_16 is
+ pragma Pure;
+
+ package Impl is new Image_N (Interfaces.Integer_16);
+
+ procedure Image_Enumeration_16
+ (Pos : Natural;
+ S : in out String;
+ P : out Natural;
+ Names : String;
+ Indexes : System.Address)
+ renames Impl.Image_Enumeration;
+
+end System.Img_Enum_16;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ E N U M _ 3 2 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Instantiation of System.Image_N for enumeration types whose names table
+-- has a length that fits in a 32-bit but not a 16-bit integer.
+
+with Interfaces;
+with System.Image_N;
+
+package System.Img_Enum_32 is
+ pragma Pure;
+
+ package Impl is new Image_N (Interfaces.Integer_32);
+
+ procedure Image_Enumeration_32
+ (Pos : Natural;
+ S : in out String;
+ P : out Natural;
+ Names : String;
+ Indexes : System.Address)
+ renames Impl.Image_Enumeration;
+
+end System.Img_Enum_32;
-- package System (where it is too early to start building image tables).
-- Special routines exist for the enumeration types in these packages.
--- This is the new version of the package, for use by compilers built after
--- Nov 21st, 2007, which provides procedures that avoid using the secondary
--- stack. The original package System.Img_Enum is maintained in the sources
--- for bootstrapping with older versions of the compiler which expect to find
--- functions in this package.
+-- Note: this is an obsolete package replaced by instantiations of the generic
+-- package System.Image_N. The reason we maintain this package is that when
+-- bootstrapping with an old compiler, the old compiler will search for this
+-- unit, expecting to find these functions. The new compiler will search for
+-- procedures in the instances of System.Image_N instead.
pragma Compiler_Unit_Warning;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ E N U M _ 8 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Instantiation of System.Image_N for enumeration types whose names table
+-- has a length that fits in a 8-bit integer.
+
+with Interfaces;
+with System.Image_N;
+
+package System.Img_Enum_8 is
+ pragma Pure;
+
+ package Impl is new Image_N (Interfaces.Integer_8);
+
+ procedure Image_Enumeration_8
+ (Pos : Natural;
+ S : in out String;
+ P : out Natural;
+ Names : String;
+ Indexes : System.Address)
+ renames Impl.Image_Enumeration;
+
+end System.Img_Enum_8;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P E R F E C T _ H A S H _ G E N E R A T O R S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-2021, 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 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 GNAT.Heap_Sort_G;
+with GNAT.Table;
+
+with System.OS_Lib; use System.OS_Lib;
+
+package body System.Perfect_Hash_Generators is
+
+ -- We are using the algorithm of J. Czech as described in Zbigniew J.
+ -- Czech, George Havas, and Bohdan S. Majewski ``An Optimal Algorithm for
+ -- Generating Minimal Perfect Hash Functions'', Information Processing
+ -- Letters, 43(1992) pp.257-264, Oct.1992
+
+ -- This minimal perfect hash function generator is based on random graphs
+ -- and produces a hash function of the form:
+
+ -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
+
+ -- where f1 and f2 are functions that map strings into integers, and g is
+ -- a function that maps integers into [0, m-1]. h can be order preserving.
+ -- For instance, let W = {w_0, ..., w_i, ..., w_m-1}, h can be defined
+ -- such that h (w_i) = i.
+
+ -- This algorithm defines two possible constructions of f1 and f2. Method
+ -- b) stores the hash function in less memory space at the expense of
+ -- greater CPU time.
+
+ -- a) fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n
+
+ -- size (Tk) = max (for w in W) (length (w)) * size (used char set)
+
+ -- b) fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n
+
+ -- size (Tk) = max (for w in W) (length (w)) but the table lookups are
+ -- replaced by multiplications.
+
+ -- where Tk values are randomly generated. n is defined later on but the
+ -- algorithm recommends to use a value a little bit greater than 2m. Note
+ -- that for large values of m, the main memory space requirements comes
+ -- from the memory space for storing function g (>= 2m entries).
+
+ -- Random graphs are frequently used to solve difficult problems that do
+ -- not have polynomial solutions. This algorithm is based on a weighted
+ -- undirected graph. It comprises two steps: mapping and assignment.
+
+ -- In the mapping step, a graph G = (V, E) is constructed, where = {0, 1,
+ -- ..., n-1} and E = {(for w in W) (f1 (w), f2 (w))}. In order for the
+ -- assignment step to be successful, G has to be acyclic. To have a high
+ -- probability of generating an acyclic graph, n >= 2m. If it is not
+ -- acyclic, Tk have to be regenerated.
+
+ -- In the assignment step, the algorithm builds function g. As G is
+ -- acyclic, there is a vertex v1 with only one neighbor v2. Let w_i be
+ -- the word such that v1 = f1 (w_i) and v2 = f2 (w_i). Let g (v1) = 0 by
+ -- construction and g (v2) = (i - g (v1)) mod n (or h (i) - g (v1) mod n).
+ -- If word w_j is such that v2 = f1 (w_j) and v3 = f2 (w_j), g (v3) = (j -
+ -- g (v2)) mod (or to be general, (h (j) - g (v2)) mod n). If w_i has no
+ -- neighbor, then another vertex is selected. The algorithm traverses G to
+ -- assign values to all the vertices. It cannot assign a value to an
+ -- already assigned vertex as G is acyclic.
+
+ subtype Word_Id is Integer;
+ subtype Key_Id is Integer;
+ subtype Vertex_Id is Integer;
+ subtype Edge_Id is Integer;
+ subtype Table_Id is Integer;
+
+ No_Vertex : constant Vertex_Id := -1;
+ No_Edge : constant Edge_Id := -1;
+ No_Table : constant Table_Id := -1;
+
+ type Word_Type is new String_Access;
+ 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);
+ -- Resize string W to have a length Len
+
+ type Key_Type is record
+ Edge : Edge_Id;
+ end record;
+ -- A key corresponds to an edge in the algorithm graph
+
+ type Vertex_Type is record
+ First : Edge_Id;
+ Last : Edge_Id;
+ end record;
+ -- A vertex can be involved in several edges. First and Last are the bounds
+ -- of an array of edges stored in a global edge table.
+
+ type Edge_Type is record
+ X : Vertex_Id;
+ Y : Vertex_Id;
+ Key : Key_Id;
+ end record;
+ -- An edge is a peer of vertices. In the algorithm, a key is associated to
+ -- an edge.
+
+ package WT is new GNAT.Table (Word_Type, Word_Id, 0, 32, 32);
+ package IT is new GNAT.Table (Integer, Integer, 0, 32, 32);
+ -- The two main tables. WT is used to store the words in their initial
+ -- version and in their reduced version (that is words reduced to their
+ -- significant characters). As an instance of GNAT.Table, WT does not
+ -- initialize string pointers to null. This initialization has to be done
+ -- manually when the table is allocated. IT is used to store several
+ -- tables of components containing only integers.
+
+ function Image (Int : Integer; W : Natural := 0) return String;
+ function Image (Str : String; W : Natural := 0) return String;
+ -- 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 System.OS_Lib.Standout;
+ -- Shortcuts
+
+ EOL : constant Character := ASCII.LF;
+
+ Max : constant := 78;
+ Last : Natural := 0;
+ Line : String (1 .. Max);
+ -- Use this line to provide buffered IO
+
+ procedure Add (C : Character);
+ procedure Add (S : String);
+ -- Add a character or a string in Line and update Last
+
+ procedure Put
+ (F : File_Descriptor;
+ S : String;
+ F1 : Natural;
+ L1 : Natural;
+ C1 : Natural;
+ F2 : Natural;
+ L2 : Natural;
+ C2 : Natural);
+ -- Write string S into file F as a element of an array of one or two
+ -- dimensions. Fk (resp. Lk and Ck) indicates the first (resp last and
+ -- current) index in the k-th dimension. If F1 = L1 the array is considered
+ -- as a one dimension array. This dimension is described by F2 and L2. This
+ -- routine takes care of all the parenthesis, spaces and commas needed to
+ -- format correctly the array. Moreover, the array is well indented and is
+ -- wrapped to fit in a 80 col line. When the line is full, the routine
+ -- writes it into file F. When the array is completed, the routine adds
+ -- semi-colon and writes the line into file F.
+
+ procedure New_Line (File : File_Descriptor);
+ -- Simulate Ada.Text_IO.New_Line with GNAT.OS_Lib
+
+ procedure Put (File : File_Descriptor; Str : String);
+ -- Simulate Ada.Text_IO.Put with GNAT.OS_Lib
+
+ procedure Put_Used_Char_Set (File : File_Descriptor; Title : String);
+ -- Output a title and a used character set
+
+ procedure Put_Int_Vector
+ (File : File_Descriptor;
+ Title : String;
+ Vector : Integer;
+ Length : Natural);
+ -- Output a title and a vector
+
+ procedure Put_Int_Matrix
+ (File : File_Descriptor;
+ Title : String;
+ Table : Table_Id;
+ Len_1 : Natural;
+ Len_2 : Natural);
+ -- Output a title and a matrix. When the matrix has only one non-empty
+ -- dimension (Len_2 = 0), output a vector.
+
+ procedure Put_Edges (File : File_Descriptor; Title : String);
+ -- Output a title and an edge table
+
+ procedure Put_Initial_Keys (File : File_Descriptor; Title : String);
+ -- Output a title and a key table
+
+ procedure Put_Reduced_Keys (File : File_Descriptor; Title : String);
+ -- Output a title and a key table
+
+ procedure Put_Vertex_Table (File : File_Descriptor; Title : String);
+ -- Output a title and a vertex table
+
+ ----------------------------------
+ -- Character Position Selection --
+ ----------------------------------
+
+ -- We reduce the maximum key size by selecting representative positions
+ -- in these keys. We build a matrix with one word per line. We fill the
+ -- remaining space of a line with ASCII.NUL. The heuristic selects the
+ -- position that induces the minimum number of collisions. If there are
+ -- collisions, select another position on the reduced key set responsible
+ -- of the collisions. Apply the heuristic until there is no more collision.
+
+ procedure Apply_Position_Selection;
+ -- Apply Position selection and build the reduced key table
+
+ procedure Parse_Position_Selection (Argument : String);
+ -- Parse Argument and compute the position set. Argument is list of
+ -- substrings separated by commas. Each substring represents a position
+ -- or a range of positions (like x-y).
+
+ procedure Select_Character_Set;
+ -- Define an optimized used character set like Character'Pos in order not
+ -- to allocate tables of 256 entries.
+
+ procedure Select_Char_Position;
+ -- Find a min char position set in order to reduce the max key length. The
+ -- heuristic selects the position that induces the minimum number of
+ -- collisions. If there are collisions, select another position on the
+ -- reduced key set responsible of the collisions. Apply the heuristic until
+ -- there is no collision.
+
+ -----------------------------
+ -- Random Graph Generation --
+ -----------------------------
+
+ procedure Random (Seed : in out Natural);
+ -- Simulate Ada.Discrete_Numerics.Random
+
+ procedure Generate_Mapping_Table
+ (Tab : Table_Id;
+ L1 : Natural;
+ L2 : Natural;
+ Seed : in out Natural);
+ -- Random generation of the tables below. T is already allocated
+
+ procedure Generate_Mapping_Tables
+ (Opt : Optimization;
+ Seed : in out Natural);
+ -- Generate the mapping tables T1 and T2. They are used to define fk (w) =
+ -- sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n. Keys, NK and Chars
+ -- are used to compute the matrix size.
+
+ ---------------------------
+ -- Algorithm Computation --
+ ---------------------------
+
+ procedure Compute_Edges_And_Vertices (Opt : Optimization);
+ -- Compute the edge and vertex tables. These are empty when a self loop is
+ -- detected (f1 (w) = f2 (w)). The edge table is sorted by X value and then
+ -- Y value. Keys is the key table and NK the number of keys. Chars is the
+ -- set of characters really used in Keys. NV is the number of vertices
+ -- recommended by the algorithm. T1 and T2 are the mapping tables needed to
+ -- compute f1 (w) and f2 (w).
+
+ function Acyclic return Boolean;
+ -- Return True when the graph is acyclic. Vertices is the current vertex
+ -- table and Edges the current edge table.
+
+ procedure Assign_Values_To_Vertices;
+ -- Execute the assignment step of the algorithm. Keys is the current key
+ -- table. Vertices and Edges represent the random graph. G is the result of
+ -- the assignment step such that:
+ -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
+
+ function Sum
+ (Word : Word_Type;
+ Table : Table_Id;
+ Opt : Optimization) return Natural;
+ -- For an optimization of CPU_Time return
+ -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n
+ -- For an optimization of Memory_Space return
+ -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n
+ -- Here NV = n
+
+ -------------------------------
+ -- Internal Table Management --
+ -------------------------------
+
+ function Allocate (N : Natural; S : Natural := 1) return Table_Id;
+ -- Allocate N * S ints from IT table
+
+ ----------
+ -- Keys --
+ ----------
+
+ Keys : Table_Id := No_Table;
+ NK : Natural := 0;
+ -- NK : Number of Keys
+
+ function Initial (K : Key_Id) return Word_Id;
+ pragma Inline (Initial);
+
+ function Reduced (K : Key_Id) return Word_Id;
+ pragma Inline (Reduced);
+
+ function Get_Key (N : Key_Id) return Key_Type;
+ procedure Set_Key (N : Key_Id; Item : Key_Type);
+ -- Get or Set Nth element of Keys table
+
+ ------------------
+ -- Char_Pos_Set --
+ ------------------
+
+ Char_Pos_Set : Table_Id := No_Table;
+ Char_Pos_Set_Len : Natural;
+ -- Character Selected Position Set
+
+ function Get_Char_Pos (P : Natural) return Natural;
+ procedure Set_Char_Pos (P : Natural; Item : Natural);
+ -- Get or Set the string position of the Pth selected character
+
+ -------------------
+ -- Used_Char_Set --
+ -------------------
+
+ Used_Char_Set : Table_Id := No_Table;
+ Used_Char_Set_Len : Natural;
+ -- Used Character Set : Define a new character mapping. When all the
+ -- characters are not present in the keys, in order to reduce the size
+ -- of some tables, we redefine the character mapping.
+
+ function Get_Used_Char (C : Character) return Natural;
+ procedure Set_Used_Char (C : Character; Item : Natural);
+
+ ------------
+ -- Tables --
+ ------------
+
+ T1 : Table_Id := No_Table;
+ T2 : Table_Id := No_Table;
+ T1_Len : Natural;
+ T2_Len : Natural;
+ -- T1 : Values table to compute F1
+ -- T2 : Values table to compute F2
+
+ function Get_Table (T : Integer; X, Y : Natural) return Natural;
+ procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural);
+
+ -----------
+ -- Graph --
+ -----------
+
+ G : Table_Id := No_Table;
+ G_Len : Natural;
+ -- Values table to compute G
+
+ NT : Natural;
+ -- Number of tries running the algorithm before raising an error
+
+ function Get_Graph (N : Natural) return Integer;
+ procedure Set_Graph (N : Natural; Item : Integer);
+ -- Get or Set Nth element of graph
+
+ -----------
+ -- Edges --
+ -----------
+
+ Edge_Size : constant := 3;
+ Edges : Table_Id := No_Table;
+ Edges_Len : Natural;
+ -- Edges : Edge table of the random graph G
+
+ function Get_Edges (F : Natural) return Edge_Type;
+ procedure Set_Edges (F : Natural; Item : Edge_Type);
+
+ --------------
+ -- Vertices --
+ --------------
+
+ Vertex_Size : constant := 2;
+
+ Vertices : Table_Id := No_Table;
+ -- Vertex table of the random graph G
+
+ NV : Natural;
+ -- Number of Vertices
+
+ function Get_Vertices (F : Natural) return Vertex_Type;
+ procedure Set_Vertices (F : Natural; Item : Vertex_Type);
+ -- Comments needed ???
+
+ Opt : Optimization;
+ -- Optimization mode (memory vs CPU)
+
+ Max_Key_Len : Natural := 0;
+ Min_Key_Len : Natural := 0;
+ -- Maximum and minimum of all the word length
+
+ S : Natural;
+ -- Seed
+
+ function Type_Size (L : Natural) return Natural;
+ -- Given the last L of an unsigned integer type T, return its size
+
+ -------------
+ -- Acyclic --
+ -------------
+
+ function Acyclic return Boolean is
+ Marks : array (0 .. NV - 1) of Vertex_Id := (others => No_Vertex);
+
+ function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean;
+ -- Propagate Mark from X to Y. X is already marked. Mark Y and propagate
+ -- it to the edges of Y except the one representing the same key. Return
+ -- False when Y is marked with Mark.
+
+ --------------
+ -- Traverse --
+ --------------
+
+ function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean is
+ E : constant Edge_Type := Get_Edges (Edge);
+ K : constant Key_Id := E.Key;
+ Y : constant Vertex_Id := E.Y;
+ M : constant Vertex_Id := Marks (E.Y);
+ V : Vertex_Type;
+
+ begin
+ if M = Mark then
+ return False;
+
+ elsif M = No_Vertex then
+ Marks (Y) := Mark;
+ V := Get_Vertices (Y);
+
+ for J in V.First .. V.Last loop
+
+ -- Do not propagate to the edge representing the same key
+
+ if Get_Edges (J).Key /= K
+ and then not Traverse (J, Mark)
+ then
+ return False;
+ end if;
+ end loop;
+ end if;
+
+ return True;
+ end Traverse;
+
+ Edge : Edge_Type;
+
+ -- Start of processing for Acyclic
+
+ begin
+ -- Edges valid range is
+
+ for J in 1 .. Edges_Len - 1 loop
+
+ Edge := Get_Edges (J);
+
+ -- Mark X of E when it has not been already done
+
+ if Marks (Edge.X) = No_Vertex then
+ Marks (Edge.X) := Edge.X;
+ end if;
+
+ -- Traverse E when this has not already been done
+
+ if Marks (Edge.Y) = No_Vertex
+ and then not Traverse (J, Edge.X)
+ then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end Acyclic;
+
+ ---------
+ -- Add --
+ ---------
+
+ procedure Add (C : Character) is
+ pragma Assert (C /= ASCII.NUL);
+ begin
+ Line (Last + 1) := C;
+ Last := Last + 1;
+ end Add;
+
+ ---------
+ -- Add --
+ ---------
+
+ 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
+ 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;
+
+ ------------------------------
+ -- Apply_Position_Selection --
+ ------------------------------
+
+ procedure Apply_Position_Selection is
+ begin
+ for J in 0 .. NK - 1 loop
+ declare
+ IW : constant String := WT.Table (Initial (J)).all;
+ RW : String (1 .. IW'Length) := (others => ASCII.NUL);
+ N : Natural := IW'First - 1;
+
+ begin
+ -- Select the characters of Word included in the position
+ -- selection.
+
+ for C in 0 .. Char_Pos_Set_Len - 1 loop
+ exit when IW (Get_Char_Pos (C)) = ASCII.NUL;
+ N := N + 1;
+ RW (N) := IW (Get_Char_Pos (C));
+ end loop;
+
+ -- Build the new table with the reduced word. Be careful
+ -- to deallocate the old version to avoid memory leaks.
+
+ Free_Word (WT.Table (Reduced (J)));
+ WT.Table (Reduced (J)) := New_Word (RW);
+ Set_Key (J, (Edge => No_Edge));
+ end;
+ end loop;
+ end Apply_Position_Selection;
+
+ -------------------------------
+ -- Assign_Values_To_Vertices --
+ -------------------------------
+
+ procedure Assign_Values_To_Vertices is
+ X : Vertex_Id;
+
+ procedure Assign (X : Vertex_Id);
+ -- Execute assignment on X's neighbors except the vertex that we are
+ -- coming from which is already assigned.
+
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (X : Vertex_Id) is
+ E : Edge_Type;
+ V : constant Vertex_Type := Get_Vertices (X);
+
+ begin
+ for J in V.First .. V.Last loop
+ E := Get_Edges (J);
+
+ if Get_Graph (E.Y) = -1 then
+ pragma Assert (NK /= 0);
+ Set_Graph (E.Y, (E.Key - Get_Graph (X)) mod NK);
+ Assign (E.Y);
+ end if;
+ end loop;
+ end Assign;
+
+ -- Start of processing for Assign_Values_To_Vertices
+
+ begin
+ -- Value -1 denotes an uninitialized value as it is supposed to
+ -- be in the range 0 .. NK.
+
+ if G = No_Table then
+ G_Len := NV;
+ G := Allocate (G_Len, 1);
+ end if;
+
+ for J in 0 .. G_Len - 1 loop
+ Set_Graph (J, -1);
+ end loop;
+
+ for K in 0 .. NK - 1 loop
+ X := Get_Edges (Get_Key (K).Edge).X;
+
+ if Get_Graph (X) = -1 then
+ Set_Graph (X, 0);
+ Assign (X);
+ end if;
+ end loop;
+
+ for J in 0 .. G_Len - 1 loop
+ if Get_Graph (J) = -1 then
+ Set_Graph (J, 0);
+ end if;
+ end loop;
+
+ if Verbose then
+ Put_Int_Vector (Output, "Assign Values To Vertices", G, G_Len);
+ end if;
+ end Assign_Values_To_Vertices;
+
+ -------------
+ -- Compute --
+ -------------
+
+ procedure Compute (Position : String) is
+ Success : Boolean := False;
+
+ begin
+ if NK = 0 then
+ raise Program_Error with "keywords set cannot be empty";
+ end if;
+
+ if Verbose then
+ Put_Initial_Keys (Output, "Initial Key Table");
+ end if;
+
+ if Position'Length /= 0 then
+ Parse_Position_Selection (Position);
+ else
+ Select_Char_Position;
+ end if;
+
+ if Verbose then
+ Put_Int_Vector
+ (Output, "Char Position Set", Char_Pos_Set, Char_Pos_Set_Len);
+ end if;
+
+ Apply_Position_Selection;
+
+ if Verbose then
+ Put_Reduced_Keys (Output, "Reduced Keys Table");
+ end if;
+
+ Select_Character_Set;
+
+ if Verbose then
+ Put_Used_Char_Set (Output, "Character Position Table");
+ end if;
+
+ -- Perform Czech's algorithm
+
+ for J in 1 .. NT loop
+ Generate_Mapping_Tables (Opt, S);
+ Compute_Edges_And_Vertices (Opt);
+
+ -- When graph is not empty (no self-loop from previous operation) and
+ -- not acyclic.
+
+ if 0 < Edges_Len and then Acyclic then
+ Success := True;
+ exit;
+ end if;
+ end loop;
+
+ if not Success then
+ raise Too_Many_Tries;
+ end if;
+
+ Assign_Values_To_Vertices;
+ end Compute;
+
+ --------------------------------
+ -- Compute_Edges_And_Vertices --
+ --------------------------------
+
+ procedure Compute_Edges_And_Vertices (Opt : Optimization) is
+ X : Natural;
+ Y : Natural;
+ Key : Key_Type;
+ Edge : Edge_Type;
+ Vertex : Vertex_Type;
+ Not_Acyclic : Boolean := False;
+
+ procedure Move (From : Natural; To : Natural);
+ function Lt (L, R : Natural) return Boolean;
+ -- Subprograms needed for GNAT.Heap_Sort_G
+
+ --------
+ -- Lt --
+ --------
+
+ function Lt (L, R : Natural) return Boolean is
+ EL : constant Edge_Type := Get_Edges (L);
+ ER : constant Edge_Type := Get_Edges (R);
+ begin
+ return EL.X < ER.X or else (EL.X = ER.X and then EL.Y < ER.Y);
+ end Lt;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ begin
+ Set_Edges (To, Get_Edges (From));
+ end Move;
+
+ package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
+
+ -- Start of processing for Compute_Edges_And_Vertices
+
+ begin
+ -- We store edges from 1 to 2 * NK and leave zero alone in order to use
+ -- GNAT.Heap_Sort_G.
+
+ Edges_Len := 2 * NK + 1;
+
+ if Edges = No_Table then
+ Edges := Allocate (Edges_Len, Edge_Size);
+ end if;
+
+ if Vertices = No_Table then
+ Vertices := Allocate (NV, Vertex_Size);
+ end if;
+
+ for J in 0 .. NV - 1 loop
+ Set_Vertices (J, (No_Vertex, No_Vertex - 1));
+ end loop;
+
+ -- For each w, X = f1 (w) and Y = f2 (w)
+
+ for J in 0 .. NK - 1 loop
+ Key := Get_Key (J);
+ Key.Edge := No_Edge;
+ Set_Key (J, Key);
+
+ X := Sum (WT.Table (Reduced (J)), T1, Opt);
+ Y := Sum (WT.Table (Reduced (J)), T2, Opt);
+
+ -- Discard T1 and T2 as soon as we discover a self loop
+
+ if X = Y then
+ Not_Acyclic := True;
+ exit;
+ end if;
+
+ -- We store (X, Y) and (Y, X) to ease assignment step
+
+ Set_Edges (2 * J + 1, (X, Y, J));
+ Set_Edges (2 * J + 2, (Y, X, J));
+ end loop;
+
+ -- Return an empty graph when self loop detected
+
+ if Not_Acyclic then
+ Edges_Len := 0;
+
+ else
+ if Verbose then
+ Put_Edges (Output, "Unsorted Edge Table");
+ Put_Int_Matrix (Output, "Function Table 1", T1,
+ T1_Len, T2_Len);
+ Put_Int_Matrix (Output, "Function Table 2", T2,
+ T1_Len, T2_Len);
+ end if;
+
+ -- Enforce consistency between edges and keys. Construct Vertices and
+ -- compute the list of neighbors of a vertex First .. Last as Edges
+ -- is sorted by X and then Y. To compute the neighbor list, sort the
+ -- edges.
+
+ Sorting.Sort (Edges_Len - 1);
+
+ if Verbose then
+ Put_Edges (Output, "Sorted Edge Table");
+ Put_Int_Matrix (Output, "Function Table 1", T1,
+ T1_Len, T2_Len);
+ Put_Int_Matrix (Output, "Function Table 2", T2,
+ T1_Len, T2_Len);
+ end if;
+
+ -- Edges valid range is 1 .. 2 * NK
+
+ for E in 1 .. Edges_Len - 1 loop
+ Edge := Get_Edges (E);
+ Key := Get_Key (Edge.Key);
+
+ if Key.Edge = No_Edge then
+ Key.Edge := E;
+ Set_Key (Edge.Key, Key);
+ end if;
+
+ Vertex := Get_Vertices (Edge.X);
+
+ if Vertex.First = No_Edge then
+ Vertex.First := E;
+ end if;
+
+ Vertex.Last := E;
+ Set_Vertices (Edge.X, Vertex);
+ end loop;
+
+ if Verbose then
+ Put_Reduced_Keys (Output, "Key Table");
+ Put_Edges (Output, "Edge Table");
+ Put_Vertex_Table (Output, "Vertex Table");
+ end if;
+ end if;
+ end Compute_Edges_And_Vertices;
+
+ ------------
+ -- Define --
+ ------------
+
+ procedure Define
+ (Name : Table_Name;
+ Item_Size : out Natural;
+ Length_1 : out Natural;
+ Length_2 : out Natural)
+ is
+ begin
+ case Name is
+ when Character_Position =>
+ Item_Size := 31;
+ Length_1 := Char_Pos_Set_Len;
+ Length_2 := 0;
+
+ when Used_Character_Set =>
+ Item_Size := 8;
+ Length_1 := 256;
+ Length_2 := 0;
+
+ when Function_Table_1
+ | Function_Table_2
+ =>
+ Item_Size := Type_Size (NV);
+ Length_1 := T1_Len;
+ Length_2 := T2_Len;
+
+ when Graph_Table =>
+ Item_Size := Type_Size (NK);
+ Length_1 := NV;
+ Length_2 := 0;
+ end case;
+ end Define;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize is
+ begin
+ if Verbose then
+ Put (Output, "Finalize");
+ New_Line (Output);
+ end if;
+
+ -- Deallocate all the WT components (both initial and reduced ones) to
+ -- avoid memory leaks.
+
+ for W in 0 .. WT.Last loop
+
+ -- 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;
+
+ -- Reset all variables for next usage
+
+ Keys := No_Table;
+
+ Char_Pos_Set := No_Table;
+ Char_Pos_Set_Len := 0;
+
+ Used_Char_Set := No_Table;
+ Used_Char_Set_Len := 0;
+
+ T1 := No_Table;
+ T2 := No_Table;
+
+ T1_Len := 0;
+ T2_Len := 0;
+
+ G := No_Table;
+ G_Len := 0;
+
+ Edges := No_Table;
+ Edges_Len := 0;
+
+ Vertices := No_Table;
+ NV := 0;
+
+ NK := 0;
+ Max_Key_Len := 0;
+ Min_Key_Len := 0;
+ end Finalize;
+
+ ----------------------------
+ -- Generate_Mapping_Table --
+ ----------------------------
+
+ procedure Generate_Mapping_Table
+ (Tab : Integer;
+ L1 : Natural;
+ L2 : Natural;
+ Seed : in out Natural)
+ is
+ begin
+ for J in 0 .. L1 - 1 loop
+ for K in 0 .. L2 - 1 loop
+ Random (Seed);
+ Set_Table (Tab, J, K, Seed mod NV);
+ end loop;
+ end loop;
+ end Generate_Mapping_Table;
+
+ -----------------------------
+ -- Generate_Mapping_Tables --
+ -----------------------------
+
+ procedure Generate_Mapping_Tables
+ (Opt : Optimization;
+ Seed : in out Natural)
+ is
+ begin
+ -- If T1 and T2 are already allocated no need to do it twice. Reuse them
+ -- as their size has not changed.
+
+ if T1 = No_Table and then T2 = No_Table then
+ declare
+ Used_Char_Last : Natural := 0;
+ Used_Char : Natural;
+
+ begin
+ if Opt = CPU_Time then
+ for P in reverse Character'Range loop
+ Used_Char := Get_Used_Char (P);
+ if Used_Char /= 0 then
+ Used_Char_Last := Used_Char;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ T1_Len := Char_Pos_Set_Len;
+ T2_Len := Used_Char_Last + 1;
+ T1 := Allocate (T1_Len * T2_Len);
+ T2 := Allocate (T1_Len * T2_Len);
+ end;
+ end if;
+
+ Generate_Mapping_Table (T1, T1_Len, T2_Len, Seed);
+ Generate_Mapping_Table (T2, T1_Len, T2_Len, Seed);
+
+ if Verbose then
+ Put_Used_Char_Set (Output, "Used Character Set");
+ Put_Int_Matrix (Output, "Function Table 1", T1,
+ T1_Len, T2_Len);
+ Put_Int_Matrix (Output, "Function Table 2", T2,
+ T1_Len, T2_Len);
+ end if;
+ end Generate_Mapping_Tables;
+
+ ------------------
+ -- Get_Char_Pos --
+ ------------------
+
+ function Get_Char_Pos (P : Natural) return Natural is
+ N : constant Natural := Char_Pos_Set + P;
+ begin
+ return IT.Table (N);
+ end Get_Char_Pos;
+
+ ---------------
+ -- Get_Edges --
+ ---------------
+
+ function Get_Edges (F : Natural) return Edge_Type is
+ N : constant Natural := Edges + (F * Edge_Size);
+ E : Edge_Type;
+ begin
+ E.X := IT.Table (N);
+ E.Y := IT.Table (N + 1);
+ E.Key := IT.Table (N + 2);
+ return E;
+ end Get_Edges;
+
+ ---------------
+ -- Get_Graph --
+ ---------------
+
+ function Get_Graph (N : Natural) return Integer is
+ begin
+ return IT.Table (G + N);
+ end Get_Graph;
+
+ -------------
+ -- Get_Key --
+ -------------
+
+ function Get_Key (N : Key_Id) return Key_Type is
+ K : Key_Type;
+ begin
+ K.Edge := IT.Table (Keys + N);
+ return K;
+ end Get_Key;
+
+ ---------------
+ -- Get_Table --
+ ---------------
+
+ function Get_Table (T : Integer; X, Y : Natural) return Natural is
+ N : constant Natural := T + (Y * T1_Len) + X;
+ begin
+ return IT.Table (N);
+ end Get_Table;
+
+ -------------------
+ -- Get_Used_Char --
+ -------------------
+
+ function Get_Used_Char (C : Character) return Natural is
+ N : constant Natural := Used_Char_Set + Character'Pos (C);
+ begin
+ return IT.Table (N);
+ end Get_Used_Char;
+
+ ------------------
+ -- Get_Vertices --
+ ------------------
+
+ function Get_Vertices (F : Natural) return Vertex_Type is
+ N : constant Natural := Vertices + (F * Vertex_Size);
+ V : Vertex_Type;
+ begin
+ V.First := IT.Table (N);
+ V.Last := IT.Table (N + 1);
+ return V;
+ end Get_Vertices;
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image (Int : Integer; W : Natural := 0) return String is
+ B : String (1 .. 32);
+ L : Natural := 0;
+
+ procedure Img (V : Natural);
+ -- Compute image of V into B, starting at B (L), incrementing L
+
+ ---------
+ -- Img --
+ ---------
+
+ procedure Img (V : Natural) is
+ begin
+ if V > 9 then
+ Img (V / 10);
+ end if;
+
+ L := L + 1;
+ B (L) := Character'Val ((V mod 10) + Character'Pos ('0'));
+ end Img;
+
+ -- Start of processing for Image
+
+ begin
+ if Int < 0 then
+ L := L + 1;
+ B (L) := '-';
+ Img (-Int);
+ else
+ Img (Int);
+ end if;
+
+ return Image (B (1 .. L), W);
+ end Image;
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image (Str : String; W : Natural := 0) return String is
+ Len : constant Natural := Str'Length;
+ Max : Natural := Len;
+
+ begin
+ if Max < W then
+ Max := W;
+ end if;
+
+ declare
+ Buf : String (1 .. Max) := (1 .. Max => ' ');
+
+ begin
+ for J in 0 .. Len - 1 loop
+ Buf (Max - Len + 1 + J) := Str (Str'First + J);
+ end loop;
+
+ return Buf;
+ end;
+ end Image;
+
+ -------------
+ -- Initial --
+ -------------
+
+ function Initial (K : Key_Id) return Word_Id is
+ begin
+ return K;
+ end Initial;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize
+ (Seed : Natural;
+ V : Positive;
+ Optim : Optimization;
+ Tries : Positive)
+ is
+ begin
+ if Verbose then
+ Put (Output, "Initialize");
+ New_Line (Output);
+ end if;
+
+ -- Deallocate the part of the table concerning the reduced words.
+ -- Initial words are already present in the table. We may have reduced
+ -- words already there because a previous computation failed. We are
+ -- currently retrying and the reduced words have to be deallocated.
+
+ for W in Reduced (0) .. WT.Last loop
+ Free_Word (WT.Table (W));
+ end loop;
+
+ IT.Init;
+
+ -- Initialize of computation variables
+
+ Keys := No_Table;
+
+ Char_Pos_Set := No_Table;
+ Char_Pos_Set_Len := 0;
+
+ Used_Char_Set := No_Table;
+ Used_Char_Set_Len := 0;
+
+ T1 := No_Table;
+ T2 := No_Table;
+
+ T1_Len := 0;
+ T2_Len := 0;
+
+ G := No_Table;
+ G_Len := 0;
+
+ Edges := No_Table;
+ Edges_Len := 0;
+
+ if V <= 2 * NK then
+ raise Program_Error with "K to V ratio cannot be lower than 2";
+ end if;
+
+ Vertices := No_Table;
+ NV := V;
+
+ S := Seed;
+ Opt := Optim;
+ NT := Tries;
+
+ Keys := Allocate (NK);
+
+ -- Resize initial words to have all of them at the same size
+ -- (so the size of the largest one).
+
+ for K in 0 .. NK - 1 loop
+ Resize_Word (WT.Table (Initial (K)), Max_Key_Len);
+ end loop;
+
+ -- Allocated the table to store the reduced words. As WT is a
+ -- GNAT.Table (using C memory management), pointers have to be
+ -- 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;
+ end Initialize;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert (Value : String) is
+ Len : constant Natural := Value'Length;
+
+ begin
+ if Verbose then
+ Put (Output, "Inserting """ & Value & """");
+ 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;
+
+ if Max_Key_Len < Len then
+ Max_Key_Len := Len;
+ end if;
+
+ if Min_Key_Len = 0 or else Len < Min_Key_Len then
+ Min_Key_Len := Len;
+ end if;
+ end Insert;
+
+ --------------
+ -- New_Line --
+ --------------
+
+ procedure New_Line (File : File_Descriptor) is
+ begin
+ if Write (File, EOL'Address, 1) /= 1 then
+ raise Program_Error;
+ end if;
+ end New_Line;
+
+ --------------
+ -- New_Word --
+ --------------
+
+ function New_Word (S : String) return Word_Type is
+ begin
+ return new String'(S);
+ end New_Word;
+
+ ------------------------------
+ -- Parse_Position_Selection --
+ ------------------------------
+
+ procedure Parse_Position_Selection (Argument : String) is
+ N : Natural := Argument'First;
+ L : constant Natural := Argument'Last;
+ M : constant Natural := Max_Key_Len;
+
+ T : array (1 .. M) of Boolean := (others => False);
+
+ function Parse_Index return Natural;
+ -- Parse argument starting at index N to find an index
+
+ -----------------
+ -- Parse_Index --
+ -----------------
+
+ function Parse_Index return Natural is
+ C : Character := Argument (N);
+ V : Natural := 0;
+
+ begin
+ if C = '$' then
+ N := N + 1;
+ return M;
+ end if;
+
+ if C not in '0' .. '9' then
+ raise Program_Error with "cannot read position argument";
+ end if;
+
+ while C in '0' .. '9' loop
+ V := V * 10 + (Character'Pos (C) - Character'Pos ('0'));
+ N := N + 1;
+ exit when L < N;
+ C := Argument (N);
+ end loop;
+
+ return V;
+ end Parse_Index;
+
+ -- Start of processing for Parse_Position_Selection
+
+ begin
+ -- Empty specification means all the positions
+
+ if L < N then
+ Char_Pos_Set_Len := M;
+ Char_Pos_Set := Allocate (Char_Pos_Set_Len);
+
+ for C in 0 .. Char_Pos_Set_Len - 1 loop
+ Set_Char_Pos (C, C + 1);
+ end loop;
+
+ else
+ loop
+ declare
+ First, Last : Natural;
+
+ begin
+ First := Parse_Index;
+ Last := First;
+
+ -- Detect a range
+
+ if N <= L and then Argument (N) = '-' then
+ N := N + 1;
+ Last := Parse_Index;
+ end if;
+
+ -- Include the positions in the selection
+
+ for J in First .. Last loop
+ T (J) := True;
+ end loop;
+ end;
+
+ exit when L < N;
+
+ if Argument (N) /= ',' then
+ raise Program_Error with "cannot read position argument";
+ end if;
+
+ N := N + 1;
+ end loop;
+
+ -- Compute position selection length
+
+ N := 0;
+ for J in T'Range loop
+ if T (J) then
+ N := N + 1;
+ end if;
+ end loop;
+
+ -- Fill position selection
+
+ Char_Pos_Set_Len := N;
+ Char_Pos_Set := Allocate (Char_Pos_Set_Len);
+
+ N := 0;
+ for J in T'Range loop
+ if T (J) then
+ Set_Char_Pos (N, J);
+ N := N + 1;
+ end if;
+ end loop;
+ end if;
+ end Parse_Position_Selection;
+
+ ---------
+ -- Put --
+ ---------
+
+ 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;
+ end Put;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (F : File_Descriptor;
+ S : String;
+ F1 : Natural;
+ L1 : Natural;
+ C1 : Natural;
+ F2 : Natural;
+ L2 : Natural;
+ C2 : Natural)
+ is
+ Len : constant Natural := S'Length;
+
+ procedure Flush;
+ -- Write current line, followed by LF
+
+ -----------
+ -- Flush --
+ -----------
+
+ procedure Flush is
+ begin
+ Put (F, Line (1 .. Last));
+ New_Line (F);
+ Last := 0;
+ end Flush;
+
+ -- Start of processing for Put
+
+ begin
+ if C1 = F1 and then C2 = F2 then
+ Last := 0;
+ end if;
+
+ if Last + Len + 3 >= Max then
+ Flush;
+ end if;
+
+ if Last = 0 then
+ Add (" ");
+
+ if F1 <= L1 then
+ if C1 = F1 and then C2 = F2 then
+ Add ('(');
+
+ if F1 = L1 then
+ Add ("0 .. 0 => ");
+ end if;
+
+ else
+ Add (' ');
+ end if;
+ end if;
+ end if;
+
+ if C2 = F2 then
+ Add ('(');
+
+ if F2 = L2 then
+ Add ("0 .. 0 => ");
+ end if;
+
+ else
+ Add (' ');
+ end if;
+
+ Add (S);
+
+ if C2 = L2 then
+ Add (')');
+
+ if F1 > L1 then
+ Add (';');
+ Flush;
+
+ elsif C1 /= L1 then
+ Add (',');
+ Flush;
+
+ else
+ Add (')');
+ Add (';');
+ Flush;
+ end if;
+
+ else
+ Add (',');
+ end if;
+ end Put;
+
+ ---------------
+ -- Put_Edges --
+ ---------------
+
+ procedure Put_Edges (File : File_Descriptor; Title : String) is
+ E : Edge_Type;
+ F1 : constant Natural := 1;
+ L1 : constant Natural := Edges_Len - 1;
+ M : constant Natural := Max / 5;
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ -- Edges valid range is 1 .. Edge_Len - 1
+
+ for J in F1 .. L1 loop
+ E := Get_Edges (J);
+ Put (File, Image (J, M), F1, L1, J, 1, 4, 1);
+ Put (File, Image (E.X, M), F1, L1, J, 1, 4, 2);
+ Put (File, Image (E.Y, M), F1, L1, J, 1, 4, 3);
+ Put (File, Image (E.Key, M), F1, L1, J, 1, 4, 4);
+ end loop;
+ end Put_Edges;
+
+ ----------------------
+ -- Put_Initial_Keys --
+ ----------------------
+
+ procedure Put_Initial_Keys (File : File_Descriptor; Title : String) is
+ F1 : constant Natural := 0;
+ L1 : constant Natural := NK - 1;
+ M : constant Natural := Max / 5;
+ K : Key_Type;
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ for J in F1 .. L1 loop
+ 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, Trim_Trailing_Nuls (WT.Table (Initial (J)).all),
+ F1, L1, J, 1, 3, 3);
+ end loop;
+ end Put_Initial_Keys;
+
+ --------------------
+ -- Put_Int_Matrix --
+ --------------------
+
+ procedure Put_Int_Matrix
+ (File : File_Descriptor;
+ Title : String;
+ Table : Integer;
+ Len_1 : Natural;
+ Len_2 : Natural)
+ is
+ F1 : constant Integer := 0;
+ L1 : constant Integer := Len_1 - 1;
+ F2 : constant Integer := 0;
+ L2 : constant Integer := Len_2 - 1;
+ Ix : Natural;
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ if Len_2 = 0 then
+ for J in F1 .. L1 loop
+ Ix := IT.Table (Table + J);
+ Put (File, Image (Ix), 1, 0, 1, F1, L1, J);
+ end loop;
+
+ else
+ for J in F1 .. L1 loop
+ for K in F2 .. L2 loop
+ Ix := IT.Table (Table + J + K * Len_1);
+ Put (File, Image (Ix), F1, L1, J, F2, L2, K);
+ end loop;
+ end loop;
+ end if;
+ end Put_Int_Matrix;
+
+ --------------------
+ -- Put_Int_Vector --
+ --------------------
+
+ procedure Put_Int_Vector
+ (File : File_Descriptor;
+ Title : String;
+ Vector : Integer;
+ Length : Natural)
+ is
+ F2 : constant Natural := 0;
+ L2 : constant Natural := Length - 1;
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ for J in F2 .. L2 loop
+ Put (File, Image (IT.Table (Vector + J)), 1, 0, 1, F2, L2, J);
+ end loop;
+ end Put_Int_Vector;
+
+ ----------------------
+ -- Put_Reduced_Keys --
+ ----------------------
+
+ procedure Put_Reduced_Keys (File : File_Descriptor; Title : String) is
+ F1 : constant Natural := 0;
+ L1 : constant Natural := NK - 1;
+ M : constant Natural := Max / 5;
+ K : Key_Type;
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ for J in F1 .. L1 loop
+ 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, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all),
+ F1, L1, J, 1, 3, 3);
+ end loop;
+ end Put_Reduced_Keys;
+
+ -----------------------
+ -- Put_Used_Char_Set --
+ -----------------------
+
+ procedure Put_Used_Char_Set (File : File_Descriptor; Title : String) is
+ F : constant Natural := Character'Pos (Character'First);
+ L : constant Natural := Character'Pos (Character'Last);
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ for J in Character'Range loop
+ Put
+ (File, Image (Get_Used_Char (J)), 1, 0, 1, F, L, Character'Pos (J));
+ end loop;
+ end Put_Used_Char_Set;
+
+ ----------------------
+ -- Put_Vertex_Table --
+ ----------------------
+
+ procedure Put_Vertex_Table (File : File_Descriptor; Title : String) is
+ F1 : constant Natural := 0;
+ L1 : constant Natural := NV - 1;
+ M : constant Natural := Max / 4;
+ V : Vertex_Type;
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ for J in F1 .. L1 loop
+ V := Get_Vertices (J);
+ Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
+ Put (File, Image (V.First, M), F1, L1, J, 1, 3, 2);
+ Put (File, Image (V.Last, M), F1, L1, J, 1, 3, 3);
+ end loop;
+ end Put_Vertex_Table;
+
+ ------------
+ -- Random --
+ ------------
+
+ procedure Random (Seed : in out Natural) is
+
+ -- Park & Miller Standard Minimal using Schrage's algorithm to avoid
+ -- overflow: Xn+1 = 16807 * Xn mod (2 ** 31 - 1)
+
+ R : Natural;
+ Q : Natural;
+ X : Integer;
+
+ begin
+ R := Seed mod 127773;
+ Q := Seed / 127773;
+ X := 16807 * R - 2836 * Q;
+
+ Seed := (if X < 0 then X + 2147483647 else X);
+ end Random;
+
+ -------------
+ -- Reduced --
+ -------------
+
+ function Reduced (K : Key_Id) return Word_Id is
+ begin
+ return K + NK + 1;
+ end Reduced;
+
+ -----------------
+ -- Resize_Word --
+ -----------------
+
+ procedure Resize_Word (W : in out Word_Type; Len : Natural) is
+ S1 : constant String := W.all;
+ S2 : String (1 .. Len) := (others => ASCII.NUL);
+ L : constant Natural := S1'Length;
+ begin
+ if L /= Len then
+ Free_Word (W);
+ S2 (1 .. L) := S1;
+ W := New_Word (S2);
+ end if;
+ end Resize_Word;
+
+ --------------------------
+ -- Select_Char_Position --
+ --------------------------
+
+ procedure Select_Char_Position is
+
+ type Vertex_Table_Type is array (Natural range <>) of Vertex_Type;
+
+ procedure Build_Identical_Keys_Sets
+ (Table : in out Vertex_Table_Type;
+ Last : in out Natural;
+ Pos : Natural);
+ -- Build a list of keys subsets that are identical with the current
+ -- position selection plus Pos. Once this routine is called, reduced
+ -- words are sorted by subsets and each item (First, Last) in Sets
+ -- defines the range of identical keys.
+ -- Need comment saying exactly what Last is ???
+
+ function Count_Different_Keys
+ (Table : Vertex_Table_Type;
+ Last : Natural;
+ Pos : Natural) return Natural;
+ -- For each subset in Sets, count the number of different keys if we add
+ -- Pos to the current position selection.
+
+ Sel_Position : IT.Table_Type (1 .. Max_Key_Len);
+ Last_Sel_Pos : Natural := 0;
+ Max_Sel_Pos : Natural := 0;
+
+ -------------------------------
+ -- Build_Identical_Keys_Sets --
+ -------------------------------
+
+ procedure Build_Identical_Keys_Sets
+ (Table : in out Vertex_Table_Type;
+ Last : in out Natural;
+ Pos : Natural)
+ is
+ S : constant Vertex_Table_Type := Table (Table'First .. Last);
+ C : constant Natural := Pos;
+ -- Shortcuts (why are these not renames ???)
+
+ F : Integer;
+ L : Integer;
+ -- First and last words of a subset
+
+ Offset : Natural;
+ -- GNAT.Heap_Sort assumes that the first array index is 1. Offset
+ -- defines the translation to operate.
+
+ function Lt (L, R : Natural) return Boolean;
+ procedure Move (From : Natural; To : Natural);
+ -- Subprograms needed by GNAT.Heap_Sort_G
+
+ --------
+ -- Lt --
+ --------
+
+ function Lt (L, R : Natural) return Boolean is
+ C : constant Natural := Pos;
+ Left : Natural;
+ Right : Natural;
+
+ begin
+ if L = 0 then
+ Left := NK;
+ Right := Offset + R;
+ elsif R = 0 then
+ Left := Offset + L;
+ Right := NK;
+ else
+ Left := Offset + L;
+ Right := Offset + R;
+ end if;
+
+ return WT.Table (Left)(C) < WT.Table (Right)(C);
+ end Lt;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ Target, Source : Natural;
+
+ begin
+ if From = 0 then
+ Source := NK;
+ Target := Offset + To;
+ elsif To = 0 then
+ Source := Offset + From;
+ Target := NK;
+ else
+ Source := Offset + From;
+ Target := Offset + To;
+ end if;
+
+ WT.Table (Target) := WT.Table (Source);
+ WT.Table (Source) := null;
+ end Move;
+
+ package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
+
+ -- Start of processing for Build_Identical_Key_Sets
+
+ begin
+ Last := 0;
+
+ -- For each subset in S, extract the new subsets we have by adding C
+ -- in the position selection.
+
+ for J in S'Range loop
+ pragma Annotate (CodePeer, Modified, S (J));
+
+ if S (J).First = S (J).Last then
+ F := S (J).First;
+ L := S (J).Last;
+ Last := Last + 1;
+ Table (Last) := (F, L);
+
+ else
+ Offset := Reduced (S (J).First) - 1;
+ Sorting.Sort (S (J).Last - S (J).First + 1);
+
+ F := S (J).First;
+ L := F;
+ for N in S (J).First .. S (J).Last loop
+
+ -- For the last item, close the last subset
+
+ if N = S (J).Last then
+ Last := Last + 1;
+ Table (Last) := (F, N);
+
+ -- Two contiguous words are identical when they have the
+ -- same Cth character.
+
+ elsif WT.Table (Reduced (N))(C) =
+ WT.Table (Reduced (N + 1))(C)
+ then
+ L := N + 1;
+
+ -- Find a new subset of identical keys. Store the current
+ -- one and create a new subset.
+
+ else
+ Last := Last + 1;
+ Table (Last) := (F, L);
+ F := N + 1;
+ L := F;
+ end if;
+ end loop;
+ end if;
+ end loop;
+ end Build_Identical_Keys_Sets;
+
+ --------------------------
+ -- Count_Different_Keys --
+ --------------------------
+
+ function Count_Different_Keys
+ (Table : Vertex_Table_Type;
+ Last : Natural;
+ Pos : Natural) return Natural
+ is
+ N : array (Character) of Natural;
+ C : Character;
+ T : Natural := 0;
+
+ begin
+ -- For each subset, count the number of words that are still
+ -- different when we include Pos in the position selection. Only
+ -- focus on this position as the other positions already produce
+ -- identical keys.
+
+ for S in 1 .. Last loop
+
+ -- Count the occurrences of the different characters
+
+ N := (others => 0);
+ for K in Table (S).First .. Table (S).Last loop
+ C := WT.Table (Reduced (K))(Pos);
+ N (C) := N (C) + 1;
+ end loop;
+
+ -- Update the number of different keys. Each character used
+ -- denotes a different key.
+
+ for J in N'Range loop
+ if N (J) > 0 then
+ T := T + 1;
+ end if;
+ end loop;
+ end loop;
+
+ return T;
+ end Count_Different_Keys;
+
+ -- Start of processing for Select_Char_Position
+
+ begin
+ -- Initialize the reduced words set
+
+ for K in 0 .. NK - 1 loop
+ WT.Table (Reduced (K)) := New_Word (WT.Table (Initial (K)).all);
+ end loop;
+
+ declare
+ Differences : Natural;
+ Max_Differences : Natural := 0;
+ Old_Differences : Natural;
+ Max_Diff_Sel_Pos : Natural := 0; -- init to kill warning
+ Max_Diff_Sel_Pos_Idx : Natural := 0; -- init to kill warning
+ Same_Keys_Sets_Table : Vertex_Table_Type (1 .. NK);
+ Same_Keys_Sets_Last : Natural := 1;
+
+ begin
+ for C in Sel_Position'Range loop
+ Sel_Position (C) := C;
+ end loop;
+
+ Same_Keys_Sets_Table (1) := (0, NK - 1);
+
+ loop
+ -- Preserve maximum number of different keys and check later on
+ -- that this value is strictly incrementing. Otherwise, it means
+ -- that two keys are strictly identical.
+
+ Old_Differences := Max_Differences;
+
+ -- The first position should not exceed the minimum key length.
+ -- Otherwise, we may end up with an empty word once reduced.
+
+ Max_Sel_Pos :=
+ (if Last_Sel_Pos = 0 then Min_Key_Len else Max_Key_Len);
+
+ -- Find which position increases more the number of differences
+
+ for J in Last_Sel_Pos + 1 .. Max_Sel_Pos loop
+ Differences := Count_Different_Keys
+ (Same_Keys_Sets_Table,
+ Same_Keys_Sets_Last,
+ Sel_Position (J));
+
+ if Verbose then
+ Put (Output,
+ "Selecting position" & Sel_Position (J)'Img &
+ " results in" & Differences'Img &
+ " differences");
+ New_Line (Output);
+ end if;
+
+ if Differences > Max_Differences then
+ Max_Differences := Differences;
+ Max_Diff_Sel_Pos := Sel_Position (J);
+ Max_Diff_Sel_Pos_Idx := J;
+ end if;
+ end loop;
+
+ if Old_Differences = Max_Differences then
+ raise Program_Error with "some keys are identical";
+ end if;
+
+ -- Insert selected position and sort Sel_Position table
+
+ Last_Sel_Pos := Last_Sel_Pos + 1;
+ Sel_Position (Last_Sel_Pos + 1 .. Max_Diff_Sel_Pos_Idx) :=
+ Sel_Position (Last_Sel_Pos .. Max_Diff_Sel_Pos_Idx - 1);
+ Sel_Position (Last_Sel_Pos) := Max_Diff_Sel_Pos;
+
+ for P in 1 .. Last_Sel_Pos - 1 loop
+ if Max_Diff_Sel_Pos < Sel_Position (P) then
+ pragma Annotate
+ (CodePeer, False_Positive,
+ "test always false", "false positive?");
+
+ Sel_Position (P + 1 .. Last_Sel_Pos) :=
+ Sel_Position (P .. Last_Sel_Pos - 1);
+ Sel_Position (P) := Max_Diff_Sel_Pos;
+ exit;
+ end if;
+ end loop;
+
+ exit when Max_Differences = NK;
+
+ Build_Identical_Keys_Sets
+ (Same_Keys_Sets_Table,
+ Same_Keys_Sets_Last,
+ Max_Diff_Sel_Pos);
+
+ if Verbose then
+ Put (Output,
+ "Selecting position" & Max_Diff_Sel_Pos'Img &
+ " results in" & Max_Differences'Img &
+ " differences");
+ New_Line (Output);
+ Put (Output, "--");
+ New_Line (Output);
+ for J in 1 .. Same_Keys_Sets_Last loop
+ for K in
+ Same_Keys_Sets_Table (J).First ..
+ Same_Keys_Sets_Table (J).Last
+ loop
+ Put (Output,
+ Trim_Trailing_Nuls (WT.Table (Reduced (K)).all));
+ New_Line (Output);
+ end loop;
+ Put (Output, "--");
+ New_Line (Output);
+ end loop;
+ end if;
+ end loop;
+ end;
+
+ Char_Pos_Set_Len := Last_Sel_Pos;
+ Char_Pos_Set := Allocate (Char_Pos_Set_Len);
+
+ for C in 1 .. Last_Sel_Pos loop
+ Set_Char_Pos (C - 1, Sel_Position (C));
+ end loop;
+ end Select_Char_Position;
+
+ --------------------------
+ -- Select_Character_Set --
+ --------------------------
+
+ procedure Select_Character_Set is
+ Last : Natural := 0;
+ Used : array (Character) of Boolean := (others => False);
+ Char : Character;
+
+ begin
+ for J in 0 .. NK - 1 loop
+ for K in 0 .. Char_Pos_Set_Len - 1 loop
+ Char := WT.Table (Initial (J))(Get_Char_Pos (K));
+ exit when Char = ASCII.NUL;
+ Used (Char) := True;
+ end loop;
+ end loop;
+
+ Used_Char_Set_Len := 256;
+ Used_Char_Set := Allocate (Used_Char_Set_Len);
+
+ for J in Used'Range loop
+ if Used (J) then
+ Set_Used_Char (J, Last);
+ Last := Last + 1;
+ else
+ Set_Used_Char (J, 0);
+ end if;
+ end loop;
+ end Select_Character_Set;
+
+ ------------------
+ -- Set_Char_Pos --
+ ------------------
+
+ procedure Set_Char_Pos (P : Natural; Item : Natural) is
+ N : constant Natural := Char_Pos_Set + P;
+ begin
+ IT.Table (N) := Item;
+ end Set_Char_Pos;
+
+ ---------------
+ -- Set_Edges --
+ ---------------
+
+ procedure Set_Edges (F : Natural; Item : Edge_Type) is
+ N : constant Natural := Edges + (F * Edge_Size);
+ begin
+ IT.Table (N) := Item.X;
+ IT.Table (N + 1) := Item.Y;
+ IT.Table (N + 2) := Item.Key;
+ end Set_Edges;
+
+ ---------------
+ -- Set_Graph --
+ ---------------
+
+ procedure Set_Graph (N : Natural; Item : Integer) is
+ begin
+ IT.Table (G + N) := Item;
+ end Set_Graph;
+
+ -------------
+ -- Set_Key --
+ -------------
+
+ procedure Set_Key (N : Key_Id; Item : Key_Type) is
+ begin
+ IT.Table (Keys + N) := Item.Edge;
+ end Set_Key;
+
+ ---------------
+ -- Set_Table --
+ ---------------
+
+ procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural) is
+ N : constant Natural := T + ((Y * T1_Len) + X);
+ begin
+ IT.Table (N) := Item;
+ end Set_Table;
+
+ -------------------
+ -- Set_Used_Char --
+ -------------------
+
+ procedure Set_Used_Char (C : Character; Item : Natural) is
+ N : constant Natural := Used_Char_Set + Character'Pos (C);
+ begin
+ IT.Table (N) := Item;
+ end Set_Used_Char;
+
+ ------------------
+ -- Set_Vertices --
+ ------------------
+
+ procedure Set_Vertices (F : Natural; Item : Vertex_Type) is
+ N : constant Natural := Vertices + (F * Vertex_Size);
+ begin
+ IT.Table (N) := Item.First;
+ IT.Table (N + 1) := Item.Last;
+ end Set_Vertices;
+
+ ---------
+ -- Sum --
+ ---------
+
+ function Sum
+ (Word : Word_Type;
+ Table : Table_Id;
+ Opt : Optimization) return Natural
+ is
+ S : Natural := 0;
+ R : Natural;
+
+ begin
+ 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)));
+ pragma Assert (NV /= 0);
+ S := (S + R) mod NV;
+ end loop;
+
+ when Memory_Space =>
+ for J in 0 .. T1_Len - 1 loop
+ exit when Word (J + 1) = ASCII.NUL;
+ R := Get_Table (Table, J, 0);
+ pragma Assert (NV /= 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 --
+ ---------------
+
+ function Type_Size (L : Natural) return Natural is
+ begin
+ if L <= 2 ** 8 then
+ return 8;
+ elsif L <= 2 ** 16 then
+ return 16;
+ else
+ return 32;
+ end if;
+ end Type_Size;
+
+ -----------
+ -- Value --
+ -----------
+
+ function Value
+ (Name : Table_Name;
+ J : Natural;
+ K : Natural := 0) return Natural
+ is
+ begin
+ case Name is
+ when Character_Position =>
+ return Get_Char_Pos (J);
+
+ when Used_Character_Set =>
+ return Get_Used_Char (Character'Val (J));
+
+ when Function_Table_1 =>
+ return Get_Table (T1, J, K);
+
+ when Function_Table_2 =>
+ return Get_Table (T2, J, K);
+
+ when Graph_Table =>
+ return Get_Graph (J);
+ end case;
+ end Value;
+
+end System.Perfect_Hash_Generators;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P E R F E C T _ H A S H _ G E N E R A T O R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002-2021, 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 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a generator of static minimal perfect hash functions.
+-- To understand what a perfect hash function is, we define several notions.
+-- These definitions are inspired from the following paper:
+
+-- Zbigniew J. Czech, George Havas, and Bohdan S. Majewski ``An Optimal
+-- Algorithm for Generating Minimal Perfect Hash Functions'', Information
+-- Processing Letters, 43(1992) pp.257-264, Oct.1992
+
+-- Let W be a set of m words. A hash function h is a function that maps the
+-- set of words W into some given interval I of integers [0, k-1], where k is
+-- an integer, usually k >= m. h (w) where w is a word in W computes an
+-- address or an integer from I for the storage or the retrieval of that
+-- item. The storage area used to store items is known as a hash table. Words
+-- for which the same address is computed are called synonyms. Due to the
+-- existence of synonyms a situation called collision may arise in which two
+-- items w1 and w2 have the same address. Several schemes for resolving
+-- collisions are known. A perfect hash function is an injection from the word
+-- set W to the integer interval I with k >= m. If k = m, then h is a minimal
+-- perfect hash function. A hash function is order preserving if it puts
+-- entries into the hash table in a prespecified order.
+
+-- A minimal perfect hash function is defined by two properties:
+
+-- Since no collisions occur each item can be retrieved from the table in
+-- *one* probe. This represents the "perfect" property.
+
+-- The hash table size corresponds to the exact size of W and *no larger*.
+-- This represents the "minimal" property.
+
+-- The functions generated by this package require the words to be known in
+-- advance (they are "static" hash functions). The hash functions are also
+-- order preserving. If w2 is inserted after w1 in the generator, then h (w1)
+-- < h (w2). These hashing functions are convenient for use with realtime
+-- applications.
+
+pragma Compiler_Unit_Warning;
+
+package System.Perfect_Hash_Generators is
+
+ type Optimization is (Memory_Space, CPU_Time);
+ -- Optimize either the memory space or the execution time. Note: in
+ -- practice, the optimization mode has little effect on speed. The tables
+ -- are somewhat smaller with Memory_Space.
+
+ Verbose : Boolean := False;
+ -- Output the status of the algorithm. For instance, the tables, the random
+ -- graph (edges, vertices) and selected char positions are output between
+ -- two iterations.
+
+ procedure Initialize
+ (Seed : Natural;
+ V : Positive;
+ Optim : Optimization;
+ Tries : Positive);
+ -- Initialize the generator and its internal structures. Set the number of
+ -- vertices in the random graphs. This value has to be greater than twice
+ -- the number of keys in order for the algorithm to succeed. The word set
+ -- is not modified (in particular when it is already set). For instance, it
+ -- is possible to run several times the generator with different settings
+ -- on the same words.
+ --
+ -- A classical way of doing is to Insert all the words and then to invoke
+ -- Initialize and Compute. If this fails to find a perfect hash function,
+ -- invoke Initialize again with other configuration parameters (probably
+ -- with a greater number of vertices). Once successful, invoke Define and
+ -- Value, and then Finalize.
+
+ procedure Finalize;
+ -- Deallocate the internal structures and the words table
+
+ procedure Insert (Value : String);
+ -- Insert a new word into the table. ASCII.NUL characters are not allowed.
+
+ Too_Many_Tries : exception;
+ -- Raised after Tries unsuccessful runs
+
+ procedure Compute (Position : String);
+ -- Compute the hash function. Position allows the definition of selection
+ -- of character positions used in the word hash function. Positions can be
+ -- separated by commas and ranges like x-y may be used. Character '$'
+ -- represents the final character of a word. With an empty position, the
+ -- generator automatically produces positions to reduce the memory usage.
+ -- Raise Too_Many_Tries if the algorithm does not succeed within Tries
+ -- attempts (see Initialize).
+
+ -- The procedure Define returns the lengths of an internal table and its
+ -- item type size. The function Value returns the value of each item in
+ -- the table. Together they can be used to retrieve the parameters of the
+ -- hash function which has been computed by a call to Compute.
+
+ -- The hash function has the following form:
+
+ -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
+
+ -- G is a function based on a graph table [0,n-1] -> [0,m-1]. m is the
+ -- number of keys. n is an internally computed value and it can be obtained
+ -- as the length of vector G.
+
+ -- F1 and F2 are two functions based on two function tables T1 and T2.
+ -- Their definition depends on the chosen optimization mode.
+
+ -- Only some character positions are used in the words because they are
+ -- significant. They are listed in a character position table (P in the
+ -- pseudo-code below). For instance, in {"jan", "feb", "mar", "apr", "jun",
+ -- "jul", "aug", "sep", "oct", "nov", "dec"}, only positions 2 and 3 are
+ -- significant (the first character can be ignored). In this example, P =
+ -- {2, 3}
+
+ -- When Optimization is CPU_Time, the first dimension of T1 and T2
+ -- corresponds to the character position in the word and the second to the
+ -- character set. As all the character set is not used, we define a used
+ -- character table which associates a distinct index to each used character
+ -- (unused characters are mapped to zero). In this case, the second
+ -- dimension of T1 and T2 is reduced to the used character set (C in the
+ -- pseudo-code below). Therefore, the hash function has the following:
+
+ -- function Hash (S : String) return Natural is
+ -- F : constant Natural := S'First - 1;
+ -- L : constant Natural := S'Length;
+ -- F1, F2 : Natural := 0;
+ -- J : <t>;
+
+ -- begin
+ -- for K in P'Range loop
+ -- exit when L < P (K);
+ -- J := C (S (P (K) + F));
+ -- F1 := (F1 + Natural (T1 (K, J))) mod <n>;
+ -- F2 := (F2 + Natural (T2 (K, J))) mod <n>;
+ -- end loop;
+
+ -- return (Natural (G (F1)) + Natural (G (F2))) mod <m>;
+ -- end Hash;
+
+ -- When Optimization is Memory_Space, the first dimension of T1 and T2
+ -- corresponds to the character position in the word and the second
+ -- dimension is ignored. T1 and T2 are no longer matrices but vectors.
+ -- Therefore, the used character table is not available. The hash function
+ -- has the following form:
+
+ -- function Hash (S : String) return Natural is
+ -- F : constant Natural := S'First - 1;
+ -- L : constant Natural := S'Length;
+ -- F1, F2 : Natural := 0;
+ -- J : <t>;
+
+ -- begin
+ -- for K in P'Range loop
+ -- exit when L < P (K);
+ -- J := Character'Pos (S (P (K) + F));
+ -- F1 := (F1 + Natural (T1 (K) * J)) mod <n>;
+ -- F2 := (F2 + Natural (T2 (K) * J)) mod <n>;
+ -- end loop;
+
+ -- return (Natural (G (F1)) + Natural (G (F2))) mod <m>;
+ -- end Hash;
+
+ type Table_Name is
+ (Character_Position,
+ Used_Character_Set,
+ Function_Table_1,
+ Function_Table_2,
+ Graph_Table);
+
+ procedure Define
+ (Name : Table_Name;
+ Item_Size : out Natural;
+ Length_1 : out Natural;
+ Length_2 : out Natural);
+ -- Return the definition of the table Name. This includes the length of
+ -- dimensions 1 and 2 and the size of an unsigned integer item. When
+ -- Length_2 is zero, the table has only one dimension. All the ranges
+ -- start from zero.
+
+ function Value
+ (Name : Table_Name;
+ J : Natural;
+ K : Natural := 0) return Natural;
+ -- Return the value of the component (J, K) of the table Name. When the
+ -- table has only one dimension, K is ignored.
+
+end System.Perfect_Hash_Generators;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ E N U M _ 1 6 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Instantiation of System.Value_N for enumeration types whose names table
+-- has a length that fits in a 16-bit but not a 8-bit integer.
+
+with Interfaces;
+with System.Value_N;
+
+package System.Val_Enum_16 is
+ pragma Preelaborate;
+
+ package Impl is new Value_N (Interfaces.Integer_16);
+
+ function Value_Enumeration_16
+ (Names : String;
+ Indexes : System.Address;
+ Hash : Impl.Hash_Function_Ptr;
+ Num : Natural;
+ Str : String)
+ return Natural
+ renames Impl.Value_Enumeration;
+
+end System.Val_Enum_16;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ E N U M _ 3 2 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Instantiation of System.Value_N for enumeration types whose names table
+-- has a length that fits in a 32-bit but not a 16-bit integer.
+
+with Interfaces;
+with System.Value_N;
+
+package System.Val_Enum_32 is
+ pragma Preelaborate;
+
+ package Impl is new Value_N (Interfaces.Integer_32);
+
+ function Value_Enumeration_32
+ (Names : String;
+ Indexes : System.Address;
+ Hash : Impl.Hash_Function_Ptr;
+ Num : Natural;
+ Str : String)
+ return Natural
+ renames Impl.Value_Enumeration;
+
+end System.Val_Enum_32;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ E N U M _ 8 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Instantiation of System.Value_N for enumeration types whose names table
+-- has a length that fits in a 8-bit integer.
+
+with Interfaces;
+with System.Value_N;
+
+package System.Val_Enum_8 is
+ pragma Preelaborate;
+
+ package Impl is new Value_N (Interfaces.Integer_8);
+
+ function Value_Enumeration_8
+ (Names : String;
+ Indexes : System.Address;
+ Hash : Impl.Hash_Function_Ptr;
+ Num : Natural;
+ Str : String)
+ return Natural
+ renames Impl.Value_Enumeration;
+
+end System.Val_Enum_8;
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- S Y S T E M . V A L _ E N U M --
+-- S Y S T E M . V A L U E _ N --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
+-- Copyright (C) 2021, 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- --
with System.Val_Util; use System.Val_Util;
-package body System.Val_Enum is
+package body System.Value_N is
- -------------------------
- -- Value_Enumeration_8 --
- -------------------------
+ -----------------------
+ -- Value_Enumeration --
+ -----------------------
- function Value_Enumeration_8
+ function Value_Enumeration
(Names : String;
Indexes : System.Address;
+ Hash : Hash_Function_Ptr;
Num : Natural;
Str : String)
return Natural
is
F : Natural;
L : Natural;
+ H : Natural;
S : String (Str'Range) := Str;
- type Natural_8 is range 0 .. 2 ** 7 - 1;
- type Index_Table is array (Natural) of Natural_8;
+ subtype Names_Index is
+ Index_Type range Index_Type (Names'First)
+ .. Index_Type (Names'Last) + 1;
+ subtype Index is Natural range Natural'First .. Names'Length;
+ type Index_Table is array (Index) of Names_Index;
type Index_Table_Ptr is access Index_Table;
function To_Index_Table_Ptr is
IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
+ pragma Assert (Num + 1 in IndexesT'Range);
+
begin
Normalize_String (S, F, L);
- for J in 0 .. Num loop
- if Names
- (Natural (IndexesT (J)) ..
- Natural (IndexesT (J + 1)) - 1) = S (F .. L)
- then
- return J;
- end if;
- end loop;
-
- Bad_Value (Str);
- end Value_Enumeration_8;
-
- --------------------------
- -- Value_Enumeration_16 --
- --------------------------
-
- function Value_Enumeration_16
- (Names : String;
- Indexes : System.Address;
- Num : Natural;
- Str : String)
- return Natural
- is
- F : Natural;
- L : Natural;
- S : String (Str'Range) := Str;
-
- type Natural_16 is range 0 .. 2 ** 15 - 1;
- type Index_Table is array (Natural) of Natural_16;
- type Index_Table_Ptr is access Index_Table;
+ -- If we have a valid hash value, do a single lookup
- function To_Index_Table_Ptr is
- new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
-
- IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
-
- begin
- Normalize_String (S, F, L);
+ H := (if Hash /= null then Hash.all (S (F .. L)) else Natural'Last);
- for J in 0 .. Num loop
+ if H /= Natural'Last then
if Names
- (Natural (IndexesT (J)) ..
- Natural (IndexesT (J + 1)) - 1) = S (F .. L)
+ (Natural (IndexesT (H)) ..
+ Natural (IndexesT (H + 1)) - 1) = S (F .. L)
then
- return J;
+ return H;
end if;
- end loop;
- Bad_Value (Str);
- end Value_Enumeration_16;
-
- --------------------------
- -- Value_Enumeration_32 --
- --------------------------
+ -- Otherwise do a linear search
- function Value_Enumeration_32
- (Names : String;
- Indexes : System.Address;
- Num : Natural;
- Str : String)
- return Natural
- is
- F : Natural;
- L : Natural;
- S : String (Str'Range) := Str;
-
- type Natural_32 is range 0 .. 2 ** 31 - 1;
- type Index_Table is array (Natural) of Natural_32;
- type Index_Table_Ptr is access Index_Table;
-
- function To_Index_Table_Ptr is
- new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
-
- IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
-
- begin
- Normalize_String (S, F, L);
-
- for J in 0 .. Num loop
- if Names
- (Natural (IndexesT (J)) ..
- Natural (IndexesT (J + 1)) - 1) = S (F .. L)
- then
- return J;
- end if;
- end loop;
+ else
+ for J in 0 .. Num loop
+ if Names
+ (Natural (IndexesT (J)) ..
+ Natural (IndexesT (J + 1)) - 1) = S (F .. L)
+ then
+ return J;
+ end if;
+ end loop;
+ end if;
Bad_Value (Str);
- end Value_Enumeration_32;
+ end Value_Enumeration;
-end System.Val_Enum;
+end System.Value_N;
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- S Y S T E M . V A L _ E N U M --
+-- S Y S T E M . V A L U E _ N --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
+-- Copyright (C) 2021, 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- --
-- other than those in packages Standard and System. See unit Exp_Imgv for
-- details of the format of constructed image tables.
-package System.Val_Enum is
+generic
+
+ type Index_Type is range <>;
+
+package System.Value_N is
pragma Preelaborate;
- function Value_Enumeration_8
+ type Hash_Function_Ptr is access function (S : String) return Natural;
+
+ function Value_Enumeration
(Names : String;
Indexes : System.Address;
+ Hash : Hash_Function_Ptr;
Num : Natural;
Str : String)
return Natural;
-- other than those defined in package Standard. Names is a string with
-- a lower bound of 1 containing the characters of all the enumeration
-- literals concatenated together in sequence. Indexes is the address
- -- of an array of type array (0 .. N) of Natural_8, where N is the
+ -- of an array of type array (0 .. N) of Index_Type, where N is the
-- number of enumeration literals in the type. The Indexes values are
-- the starting subscript of each enumeration literal, indexed by Pos
-- values, with an extra entry at the end containing Names'Length + 1.
+ -- The parameter Hash is a (perfect) hash function for Names and Indexes.
-- The parameter Num is the value N - 1 (i.e. Enum'Pos (Enum'Last)).
-- The reason that Indexes is passed by address is that the actual type
-- is created on the fly by the expander.
-- If the image is found in Names, then the corresponding Pos value is
-- returned. If not, Constraint_Error is raised.
- function Value_Enumeration_16
- (Names : String;
- Indexes : System.Address;
- Num : Natural;
- Str : String)
- return Natural;
- -- Identical to Value_Enumeration_8 except that it handles types
- -- using array (0 .. Num) of Natural_16 for the Indexes table.
-
- function Value_Enumeration_32
- (Names : String;
- Indexes : System.Address;
- Num : Natural;
- Str : String)
- return Natural;
- -- Identical to Value_Enumeration_8 except that it handles types
- -- using array (0 .. Num) of Natural_32 for the Indexes table.
-
-end System.Val_Enum;
+end System.Value_N;
System_Img_Decimal_32,
System_Img_Decimal_64,
System_Img_Decimal_128,
- System_Img_Enum,
- System_Img_Enum_New,
+ System_Img_Enum_8,
+ System_Img_Enum_16,
+ System_Img_Enum_32,
System_Img_Fixed_32,
System_Img_Fixed_64,
System_Img_Fixed_128,
System_Val_Decimal_32,
System_Val_Decimal_64,
System_Val_Decimal_128,
- System_Val_Enum,
+ System_Val_Enum_8,
+ System_Val_Enum_16,
+ System_Val_Enum_32,
System_Val_Fixed_32,
System_Val_Fixed_64,
System_Val_Fixed_128,
RE_Image_Decimal128 => System_Img_Decimal_128,
- RE_Image_Enumeration_8 => System_Img_Enum_New,
- RE_Image_Enumeration_16 => System_Img_Enum_New,
- RE_Image_Enumeration_32 => System_Img_Enum_New,
+ RE_Image_Enumeration_8 => System_Img_Enum_8,
+
+ RE_Image_Enumeration_16 => System_Img_Enum_16,
+
+ RE_Image_Enumeration_32 => System_Img_Enum_32,
RE_Image_Float => System_Img_Flt,
RE_Value_Decimal128 => System_Val_Decimal_128,
- RE_Value_Enumeration_8 => System_Val_Enum,
- RE_Value_Enumeration_16 => System_Val_Enum,
- RE_Value_Enumeration_32 => System_Val_Enum,
+ RE_Value_Enumeration_8 => System_Val_Enum_8,
+
+ RE_Value_Enumeration_16 => System_Val_Enum_16,
+
+ RE_Value_Enumeration_32 => System_Val_Enum_32,
RE_Value_Fixed32 => System_Val_Fixed_32,
begin
-- Access and Unchecked_Access are illegal in declare_expressions,
- -- according to the RM. We also make the GNAT-specific
- -- Unrestricted_Access attribute illegal.
+ -- according to the RM. We also make the GNAT Unrestricted_Access
+ -- attribute illegal if it comes from source.
- if In_Declare_Expr > 0 then
+ if In_Declare_Expr > 0
+ and then (Attr_Id /= Attribute_Unrestricted_Access
+ or else Comes_From_Source (N))
+ then
Error_Attr ("% attribute cannot occur in a declare_expression", N);
end if;
projects / platform / upstream / gcc.git / commitdiff