1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G N A T . P E R F E C T _ H A S H _ G E N E R A T O R S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2002-2020, AdaCore -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with Ada.IO_Exceptions; use Ada.IO_Exceptions; 33with Ada.Characters.Handling; use Ada.Characters.Handling; 34with Ada.Directories; 35 36with GNAT.Heap_Sort_G; 37with GNAT.OS_Lib; use GNAT.OS_Lib; 38with GNAT.Table; 39 40package body GNAT.Perfect_Hash_Generators is 41 42 -- We are using the algorithm of J. Czech as described in Zbigniew J. 43 -- Czech, George Havas, and Bohdan S. Majewski ``An Optimal Algorithm for 44 -- Generating Minimal Perfect Hash Functions'', Information Processing 45 -- Letters, 43(1992) pp.257-264, Oct.1992 46 47 -- This minimal perfect hash function generator is based on random graphs 48 -- and produces a hash function of the form: 49 50 -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m 51 52 -- where f1 and f2 are functions that map strings into integers, and g is 53 -- a function that maps integers into [0, m-1]. h can be order preserving. 54 -- For instance, let W = {w_0, ..., w_i, ..., w_m-1}, h can be defined 55 -- such that h (w_i) = i. 56 57 -- This algorithm defines two possible constructions of f1 and f2. Method 58 -- b) stores the hash function in less memory space at the expense of 59 -- greater CPU time. 60 61 -- a) fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n 62 63 -- size (Tk) = max (for w in W) (length (w)) * size (used char set) 64 65 -- b) fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n 66 67 -- size (Tk) = max (for w in W) (length (w)) but the table lookups are 68 -- replaced by multiplications. 69 70 -- where Tk values are randomly generated. n is defined later on but the 71 -- algorithm recommends to use a value a little bit greater than 2m. Note 72 -- that for large values of m, the main memory space requirements comes 73 -- from the memory space for storing function g (>= 2m entries). 74 75 -- Random graphs are frequently used to solve difficult problems that do 76 -- not have polynomial solutions. This algorithm is based on a weighted 77 -- undirected graph. It comprises two steps: mapping and assignment. 78 79 -- In the mapping step, a graph G = (V, E) is constructed, where = {0, 1, 80 -- ..., n-1} and E = {(for w in W) (f1 (w), f2 (w))}. In order for the 81 -- assignment step to be successful, G has to be acyclic. To have a high 82 -- probability of generating an acyclic graph, n >= 2m. If it is not 83 -- acyclic, Tk have to be regenerated. 84 85 -- In the assignment step, the algorithm builds function g. As G is 86 -- acyclic, there is a vertex v1 with only one neighbor v2. Let w_i be 87 -- the word such that v1 = f1 (w_i) and v2 = f2 (w_i). Let g (v1) = 0 by 88 -- construction and g (v2) = (i - g (v1)) mod n (or h (i) - g (v1) mod n). 89 -- If word w_j is such that v2 = f1 (w_j) and v3 = f2 (w_j), g (v3) = (j - 90 -- g (v2)) mod (or to be general, (h (j) - g (v2)) mod n). If w_i has no 91 -- neighbor, then another vertex is selected. The algorithm traverses G to 92 -- assign values to all the vertices. It cannot assign a value to an 93 -- already assigned vertex as G is acyclic. 94 95 subtype Word_Id is Integer; 96 subtype Key_Id is Integer; 97 subtype Vertex_Id is Integer; 98 subtype Edge_Id is Integer; 99 subtype Table_Id is Integer; 100 101 No_Vertex : constant Vertex_Id := -1; 102 No_Edge : constant Edge_Id := -1; 103 No_Table : constant Table_Id := -1; 104 105 type Word_Type is new String_Access; 106 procedure Free_Word (W : in out Word_Type) renames Free; 107 function New_Word (S : String) return Word_Type; 108 109 procedure Resize_Word (W : in out Word_Type; Len : Natural); 110 -- Resize string W to have a length Len 111 112 type Key_Type is record 113 Edge : Edge_Id; 114 end record; 115 -- A key corresponds to an edge in the algorithm graph 116 117 type Vertex_Type is record 118 First : Edge_Id; 119 Last : Edge_Id; 120 end record; 121 -- A vertex can be involved in several edges. First and Last are the bounds 122 -- of an array of edges stored in a global edge table. 123 124 type Edge_Type is record 125 X : Vertex_Id; 126 Y : Vertex_Id; 127 Key : Key_Id; 128 end record; 129 -- An edge is a peer of vertices. In the algorithm, a key is associated to 130 -- an edge. 131 132 package WT is new GNAT.Table (Word_Type, Word_Id, 0, 32, 32); 133 package IT is new GNAT.Table (Integer, Integer, 0, 32, 32); 134 -- The two main tables. WT is used to store the words in their initial 135 -- version and in their reduced version (that is words reduced to their 136 -- significant characters). As an instance of GNAT.Table, WT does not 137 -- initialize string pointers to null. This initialization has to be done 138 -- manually when the table is allocated. IT is used to store several 139 -- tables of components containing only integers. 140 141 function Image (Int : Integer; W : Natural := 0) return String; 142 function Image (Str : String; W : Natural := 0) return String; 143 -- Return a string which includes string Str or integer Int preceded by 144 -- leading spaces if required by width W. 145 146 function Trim_Trailing_Nuls (Str : String) return String; 147 -- Return Str with trailing NUL characters removed 148 149 Output : File_Descriptor renames GNAT.OS_Lib.Standout; 150 -- Shortcuts 151 152 EOL : constant Character := ASCII.LF; 153 154 Max : constant := 78; 155 Last : Natural := 0; 156 Line : String (1 .. Max); 157 -- Use this line to provide buffered IO 158 159 procedure Add (C : Character); 160 procedure Add (S : String); 161 -- Add a character or a string in Line and update Last 162 163 procedure Put 164 (F : File_Descriptor; 165 S : String; 166 F1 : Natural; 167 L1 : Natural; 168 C1 : Natural; 169 F2 : Natural; 170 L2 : Natural; 171 C2 : Natural); 172 -- Write string S into file F as a element of an array of one or two 173 -- dimensions. Fk (resp. Lk and Ck) indicates the first (resp last and 174 -- current) index in the k-th dimension. If F1 = L1 the array is considered 175 -- as a one dimension array. This dimension is described by F2 and L2. This 176 -- routine takes care of all the parenthesis, spaces and commas needed to 177 -- format correctly the array. Moreover, the array is well indented and is 178 -- wrapped to fit in a 80 col line. When the line is full, the routine 179 -- writes it into file F. When the array is completed, the routine adds 180 -- semi-colon and writes the line into file F. 181 182 procedure New_Line (File : File_Descriptor); 183 -- Simulate Ada.Text_IO.New_Line with GNAT.OS_Lib 184 185 procedure Put (File : File_Descriptor; Str : String); 186 -- Simulate Ada.Text_IO.Put with GNAT.OS_Lib 187 188 procedure Put_Used_Char_Set (File : File_Descriptor; Title : String); 189 -- Output a title and a used character set 190 191 procedure Put_Int_Vector 192 (File : File_Descriptor; 193 Title : String; 194 Vector : Integer; 195 Length : Natural); 196 -- Output a title and a vector 197 198 procedure Put_Int_Matrix 199 (File : File_Descriptor; 200 Title : String; 201 Table : Table_Id; 202 Len_1 : Natural; 203 Len_2 : Natural); 204 -- Output a title and a matrix. When the matrix has only one non-empty 205 -- dimension (Len_2 = 0), output a vector. 206 207 procedure Put_Edges (File : File_Descriptor; Title : String); 208 -- Output a title and an edge table 209 210 procedure Put_Initial_Keys (File : File_Descriptor; Title : String); 211 -- Output a title and a key table 212 213 procedure Put_Reduced_Keys (File : File_Descriptor; Title : String); 214 -- Output a title and a key table 215 216 procedure Put_Vertex_Table (File : File_Descriptor; Title : String); 217 -- Output a title and a vertex table 218 219 function Ada_File_Base_Name (Pkg_Name : String) return String; 220 -- Return the base file name (i.e. without .ads/.adb extension) for an 221 -- Ada source file containing the named package, using the standard GNAT 222 -- file-naming convention. For example, if Pkg_Name is "Parent.Child", we 223 -- return "parent-child". 224 225 ---------------------------------- 226 -- Character Position Selection -- 227 ---------------------------------- 228 229 -- We reduce the maximum key size by selecting representative positions 230 -- in these keys. We build a matrix with one word per line. We fill the 231 -- remaining space of a line with ASCII.NUL. The heuristic selects the 232 -- position that induces the minimum number of collisions. If there are 233 -- collisions, select another position on the reduced key set responsible 234 -- of the collisions. Apply the heuristic until there is no more collision. 235 236 procedure Apply_Position_Selection; 237 -- Apply Position selection and build the reduced key table 238 239 procedure Parse_Position_Selection (Argument : String); 240 -- Parse Argument and compute the position set. Argument is list of 241 -- substrings separated by commas. Each substring represents a position 242 -- or a range of positions (like x-y). 243 244 procedure Select_Character_Set; 245 -- Define an optimized used character set like Character'Pos in order not 246 -- to allocate tables of 256 entries. 247 248 procedure Select_Char_Position; 249 -- Find a min char position set in order to reduce the max key length. The 250 -- heuristic selects the position that induces the minimum number of 251 -- collisions. If there are collisions, select another position on the 252 -- reduced key set responsible of the collisions. Apply the heuristic until 253 -- there is no collision. 254 255 ----------------------------- 256 -- Random Graph Generation -- 257 ----------------------------- 258 259 procedure Random (Seed : in out Natural); 260 -- Simulate Ada.Discrete_Numerics.Random 261 262 procedure Generate_Mapping_Table 263 (Tab : Table_Id; 264 L1 : Natural; 265 L2 : Natural; 266 Seed : in out Natural); 267 -- Random generation of the tables below. T is already allocated 268 269 procedure Generate_Mapping_Tables 270 (Opt : Optimization; 271 Seed : in out Natural); 272 -- Generate the mapping tables T1 and T2. They are used to define fk (w) = 273 -- sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n. Keys, NK and Chars 274 -- are used to compute the matrix size. 275 276 --------------------------- 277 -- Algorithm Computation -- 278 --------------------------- 279 280 procedure Compute_Edges_And_Vertices (Opt : Optimization); 281 -- Compute the edge and vertex tables. These are empty when a self loop is 282 -- detected (f1 (w) = f2 (w)). The edge table is sorted by X value and then 283 -- Y value. Keys is the key table and NK the number of keys. Chars is the 284 -- set of characters really used in Keys. NV is the number of vertices 285 -- recommended by the algorithm. T1 and T2 are the mapping tables needed to 286 -- compute f1 (w) and f2 (w). 287 288 function Acyclic return Boolean; 289 -- Return True when the graph is acyclic. Vertices is the current vertex 290 -- table and Edges the current edge table. 291 292 procedure Assign_Values_To_Vertices; 293 -- Execute the assignment step of the algorithm. Keys is the current key 294 -- table. Vertices and Edges represent the random graph. G is the result of 295 -- the assignment step such that: 296 -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m 297 298 function Sum 299 (Word : Word_Type; 300 Table : Table_Id; 301 Opt : Optimization) return Natural; 302 -- For an optimization of CPU_Time return 303 -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n 304 -- For an optimization of Memory_Space return 305 -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n 306 -- Here NV = n 307 308 ------------------------------- 309 -- Internal Table Management -- 310 ------------------------------- 311 312 function Allocate (N : Natural; S : Natural := 1) return Table_Id; 313 -- Allocate N * S ints from IT table 314 315 ---------- 316 -- Keys -- 317 ---------- 318 319 Keys : Table_Id := No_Table; 320 NK : Natural := 0; 321 -- NK : Number of Keys 322 323 function Initial (K : Key_Id) return Word_Id; 324 pragma Inline (Initial); 325 326 function Reduced (K : Key_Id) return Word_Id; 327 pragma Inline (Reduced); 328 329 function Get_Key (N : Key_Id) return Key_Type; 330 procedure Set_Key (N : Key_Id; Item : Key_Type); 331 -- Get or Set Nth element of Keys table 332 333 ------------------ 334 -- Char_Pos_Set -- 335 ------------------ 336 337 Char_Pos_Set : Table_Id := No_Table; 338 Char_Pos_Set_Len : Natural; 339 -- Character Selected Position Set 340 341 function Get_Char_Pos (P : Natural) return Natural; 342 procedure Set_Char_Pos (P : Natural; Item : Natural); 343 -- Get or Set the string position of the Pth selected character 344 345 ------------------- 346 -- Used_Char_Set -- 347 ------------------- 348 349 Used_Char_Set : Table_Id := No_Table; 350 Used_Char_Set_Len : Natural; 351 -- Used Character Set : Define a new character mapping. When all the 352 -- characters are not present in the keys, in order to reduce the size 353 -- of some tables, we redefine the character mapping. 354 355 function Get_Used_Char (C : Character) return Natural; 356 procedure Set_Used_Char (C : Character; Item : Natural); 357 358 ------------ 359 -- Tables -- 360 ------------ 361 362 T1 : Table_Id := No_Table; 363 T2 : Table_Id := No_Table; 364 T1_Len : Natural; 365 T2_Len : Natural; 366 -- T1 : Values table to compute F1 367 -- T2 : Values table to compute F2 368 369 function Get_Table (T : Integer; X, Y : Natural) return Natural; 370 procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural); 371 372 ----------- 373 -- Graph -- 374 ----------- 375 376 G : Table_Id := No_Table; 377 G_Len : Natural; 378 -- Values table to compute G 379 380 NT : Natural := Default_Tries; 381 -- Number of tries running the algorithm before raising an error 382 383 function Get_Graph (N : Natural) return Integer; 384 procedure Set_Graph (N : Natural; Item : Integer); 385 -- Get or Set Nth element of graph 386 387 ----------- 388 -- Edges -- 389 ----------- 390 391 Edge_Size : constant := 3; 392 Edges : Table_Id := No_Table; 393 Edges_Len : Natural; 394 -- Edges : Edge table of the random graph G 395 396 function Get_Edges (F : Natural) return Edge_Type; 397 procedure Set_Edges (F : Natural; Item : Edge_Type); 398 399 -------------- 400 -- Vertices -- 401 -------------- 402 403 Vertex_Size : constant := 2; 404 405 Vertices : Table_Id := No_Table; 406 -- Vertex table of the random graph G 407 408 NV : Natural; 409 -- Number of Vertices 410 411 function Get_Vertices (F : Natural) return Vertex_Type; 412 procedure Set_Vertices (F : Natural; Item : Vertex_Type); 413 -- Comments needed ??? 414 415 K2V : Float; 416 -- Ratio between Keys and Vertices (parameter of Czech's algorithm) 417 418 Opt : Optimization; 419 -- Optimization mode (memory vs CPU) 420 421 Max_Key_Len : Natural := 0; 422 Min_Key_Len : Natural := 0; 423 -- Maximum and minimum of all the word length 424 425 S : Natural; 426 -- Seed 427 428 function Type_Size (L : Natural) return Natural; 429 -- Given the last L of an unsigned integer type T, return its size 430 431 ------------- 432 -- Acyclic -- 433 ------------- 434 435 function Acyclic return Boolean is 436 Marks : array (0 .. NV - 1) of Vertex_Id := (others => No_Vertex); 437 438 function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean; 439 -- Propagate Mark from X to Y. X is already marked. Mark Y and propagate 440 -- it to the edges of Y except the one representing the same key. Return 441 -- False when Y is marked with Mark. 442 443 -------------- 444 -- Traverse -- 445 -------------- 446 447 function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean is 448 E : constant Edge_Type := Get_Edges (Edge); 449 K : constant Key_Id := E.Key; 450 Y : constant Vertex_Id := E.Y; 451 M : constant Vertex_Id := Marks (E.Y); 452 V : Vertex_Type; 453 454 begin 455 if M = Mark then 456 return False; 457 458 elsif M = No_Vertex then 459 Marks (Y) := Mark; 460 V := Get_Vertices (Y); 461 462 for J in V.First .. V.Last loop 463 464 -- Do not propagate to the edge representing the same key 465 466 if Get_Edges (J).Key /= K 467 and then not Traverse (J, Mark) 468 then 469 return False; 470 end if; 471 end loop; 472 end if; 473 474 return True; 475 end Traverse; 476 477 Edge : Edge_Type; 478 479 -- Start of processing for Acyclic 480 481 begin 482 -- Edges valid range is 483 484 for J in 1 .. Edges_Len - 1 loop 485 486 Edge := Get_Edges (J); 487 488 -- Mark X of E when it has not been already done 489 490 if Marks (Edge.X) = No_Vertex then 491 Marks (Edge.X) := Edge.X; 492 end if; 493 494 -- Traverse E when this has not already been done 495 496 if Marks (Edge.Y) = No_Vertex 497 and then not Traverse (J, Edge.X) 498 then 499 return False; 500 end if; 501 end loop; 502 503 return True; 504 end Acyclic; 505 506 ------------------------ 507 -- Ada_File_Base_Name -- 508 ------------------------ 509 510 function Ada_File_Base_Name (Pkg_Name : String) return String is 511 begin 512 -- Convert to lower case, then replace '.' with '-' 513 514 return Result : String := To_Lower (Pkg_Name) do 515 for J in Result'Range loop 516 if Result (J) = '.' then 517 Result (J) := '-'; 518 end if; 519 end loop; 520 end return; 521 end Ada_File_Base_Name; 522 523 --------- 524 -- Add -- 525 --------- 526 527 procedure Add (C : Character) is 528 pragma Assert (C /= ASCII.NUL); 529 begin 530 Line (Last + 1) := C; 531 Last := Last + 1; 532 end Add; 533 534 --------- 535 -- Add -- 536 --------- 537 538 procedure Add (S : String) is 539 Len : constant Natural := S'Length; 540 begin 541 for J in S'Range loop 542 pragma Assert (S (J) /= ASCII.NUL); 543 null; 544 end loop; 545 546 Line (Last + 1 .. Last + Len) := S; 547 Last := Last + Len; 548 end Add; 549 550 -------------- 551 -- Allocate -- 552 -------------- 553 554 function Allocate (N : Natural; S : Natural := 1) return Table_Id is 555 L : constant Integer := IT.Last; 556 begin 557 IT.Set_Last (L + N * S); 558 559 -- Initialize, so debugging printouts don't trip over uninitialized 560 -- components. 561 562 for J in L + 1 .. IT.Last loop 563 IT.Table (J) := -1; 564 end loop; 565 566 return L + 1; 567 end Allocate; 568 569 ------------------------------ 570 -- Apply_Position_Selection -- 571 ------------------------------ 572 573 procedure Apply_Position_Selection is 574 begin 575 for J in 0 .. NK - 1 loop 576 declare 577 IW : constant String := WT.Table (Initial (J)).all; 578 RW : String (1 .. IW'Length) := (others => ASCII.NUL); 579 N : Natural := IW'First - 1; 580 581 begin 582 -- Select the characters of Word included in the position 583 -- selection. 584 585 for C in 0 .. Char_Pos_Set_Len - 1 loop 586 exit when IW (Get_Char_Pos (C)) = ASCII.NUL; 587 N := N + 1; 588 RW (N) := IW (Get_Char_Pos (C)); 589 end loop; 590 591 -- Build the new table with the reduced word. Be careful 592 -- to deallocate the old version to avoid memory leaks. 593 594 Free_Word (WT.Table (Reduced (J))); 595 WT.Table (Reduced (J)) := New_Word (RW); 596 Set_Key (J, (Edge => No_Edge)); 597 end; 598 end loop; 599 end Apply_Position_Selection; 600 601 ------------------------------- 602 -- Assign_Values_To_Vertices -- 603 ------------------------------- 604 605 procedure Assign_Values_To_Vertices is 606 X : Vertex_Id; 607 608 procedure Assign (X : Vertex_Id); 609 -- Execute assignment on X's neighbors except the vertex that we are 610 -- coming from which is already assigned. 611 612 ------------ 613 -- Assign -- 614 ------------ 615 616 procedure Assign (X : Vertex_Id) is 617 E : Edge_Type; 618 V : constant Vertex_Type := Get_Vertices (X); 619 620 begin 621 for J in V.First .. V.Last loop 622 E := Get_Edges (J); 623 624 if Get_Graph (E.Y) = -1 then 625 pragma Assert (NK /= 0); 626 Set_Graph (E.Y, (E.Key - Get_Graph (X)) mod NK); 627 Assign (E.Y); 628 end if; 629 end loop; 630 end Assign; 631 632 -- Start of processing for Assign_Values_To_Vertices 633 634 begin 635 -- Value -1 denotes an uninitialized value as it is supposed to 636 -- be in the range 0 .. NK. 637 638 if G = No_Table then 639 G_Len := NV; 640 G := Allocate (G_Len, 1); 641 end if; 642 643 for J in 0 .. G_Len - 1 loop 644 Set_Graph (J, -1); 645 end loop; 646 647 for K in 0 .. NK - 1 loop 648 X := Get_Edges (Get_Key (K).Edge).X; 649 650 if Get_Graph (X) = -1 then 651 Set_Graph (X, 0); 652 Assign (X); 653 end if; 654 end loop; 655 656 for J in 0 .. G_Len - 1 loop 657 if Get_Graph (J) = -1 then 658 Set_Graph (J, 0); 659 end if; 660 end loop; 661 662 if Verbose then 663 Put_Int_Vector (Output, "Assign Values To Vertices", G, G_Len); 664 end if; 665 end Assign_Values_To_Vertices; 666 667 ------------- 668 -- Compute -- 669 ------------- 670 671 procedure Compute (Position : String := Default_Position) is 672 Success : Boolean := False; 673 674 begin 675 if NK = 0 then 676 raise Program_Error with "keywords set cannot be empty"; 677 end if; 678 679 if Verbose then 680 Put_Initial_Keys (Output, "Initial Key Table"); 681 end if; 682 683 if Position'Length /= 0 then 684 Parse_Position_Selection (Position); 685 else 686 Select_Char_Position; 687 end if; 688 689 if Verbose then 690 Put_Int_Vector 691 (Output, "Char Position Set", Char_Pos_Set, Char_Pos_Set_Len); 692 end if; 693 694 Apply_Position_Selection; 695 696 if Verbose then 697 Put_Reduced_Keys (Output, "Reduced Keys Table"); 698 end if; 699 700 Select_Character_Set; 701 702 if Verbose then 703 Put_Used_Char_Set (Output, "Character Position Table"); 704 end if; 705 706 -- Perform Czech's algorithm 707 708 for J in 1 .. NT loop 709 Generate_Mapping_Tables (Opt, S); 710 Compute_Edges_And_Vertices (Opt); 711 712 -- When graph is not empty (no self-loop from previous operation) and 713 -- not acyclic. 714 715 if 0 < Edges_Len and then Acyclic then 716 Success := True; 717 exit; 718 end if; 719 end loop; 720 721 if not Success then 722 raise Too_Many_Tries; 723 end if; 724 725 Assign_Values_To_Vertices; 726 end Compute; 727 728 -------------------------------- 729 -- Compute_Edges_And_Vertices -- 730 -------------------------------- 731 732 procedure Compute_Edges_And_Vertices (Opt : Optimization) is 733 X : Natural; 734 Y : Natural; 735 Key : Key_Type; 736 Edge : Edge_Type; 737 Vertex : Vertex_Type; 738 Not_Acyclic : Boolean := False; 739 740 procedure Move (From : Natural; To : Natural); 741 function Lt (L, R : Natural) return Boolean; 742 -- Subprograms needed for GNAT.Heap_Sort_G 743 744 -------- 745 -- Lt -- 746 -------- 747 748 function Lt (L, R : Natural) return Boolean is 749 EL : constant Edge_Type := Get_Edges (L); 750 ER : constant Edge_Type := Get_Edges (R); 751 begin 752 return EL.X < ER.X or else (EL.X = ER.X and then EL.Y < ER.Y); 753 end Lt; 754 755 ---------- 756 -- Move -- 757 ---------- 758 759 procedure Move (From : Natural; To : Natural) is 760 begin 761 Set_Edges (To, Get_Edges (From)); 762 end Move; 763 764 package Sorting is new GNAT.Heap_Sort_G (Move, Lt); 765 766 -- Start of processing for Compute_Edges_And_Vertices 767 768 begin 769 -- We store edges from 1 to 2 * NK and leave zero alone in order to use 770 -- GNAT.Heap_Sort_G. 771 772 Edges_Len := 2 * NK + 1; 773 774 if Edges = No_Table then 775 Edges := Allocate (Edges_Len, Edge_Size); 776 end if; 777 778 if Vertices = No_Table then 779 Vertices := Allocate (NV, Vertex_Size); 780 end if; 781 782 for J in 0 .. NV - 1 loop 783 Set_Vertices (J, (No_Vertex, No_Vertex - 1)); 784 end loop; 785 786 -- For each w, X = f1 (w) and Y = f2 (w) 787 788 for J in 0 .. NK - 1 loop 789 Key := Get_Key (J); 790 Key.Edge := No_Edge; 791 Set_Key (J, Key); 792 793 X := Sum (WT.Table (Reduced (J)), T1, Opt); 794 Y := Sum (WT.Table (Reduced (J)), T2, Opt); 795 796 -- Discard T1 and T2 as soon as we discover a self loop 797 798 if X = Y then 799 Not_Acyclic := True; 800 exit; 801 end if; 802 803 -- We store (X, Y) and (Y, X) to ease assignment step 804 805 Set_Edges (2 * J + 1, (X, Y, J)); 806 Set_Edges (2 * J + 2, (Y, X, J)); 807 end loop; 808 809 -- Return an empty graph when self loop detected 810 811 if Not_Acyclic then 812 Edges_Len := 0; 813 814 else 815 if Verbose then 816 Put_Edges (Output, "Unsorted Edge Table"); 817 Put_Int_Matrix (Output, "Function Table 1", T1, 818 T1_Len, T2_Len); 819 Put_Int_Matrix (Output, "Function Table 2", T2, 820 T1_Len, T2_Len); 821 end if; 822 823 -- Enforce consistency between edges and keys. Construct Vertices and 824 -- compute the list of neighbors of a vertex First .. Last as Edges 825 -- is sorted by X and then Y. To compute the neighbor list, sort the 826 -- edges. 827 828 Sorting.Sort (Edges_Len - 1); 829 830 if Verbose then 831 Put_Edges (Output, "Sorted Edge Table"); 832 Put_Int_Matrix (Output, "Function Table 1", T1, 833 T1_Len, T2_Len); 834 Put_Int_Matrix (Output, "Function Table 2", T2, 835 T1_Len, T2_Len); 836 end if; 837 838 -- Edges valid range is 1 .. 2 * NK 839 840 for E in 1 .. Edges_Len - 1 loop 841 Edge := Get_Edges (E); 842 Key := Get_Key (Edge.Key); 843 844 if Key.Edge = No_Edge then 845 Key.Edge := E; 846 Set_Key (Edge.Key, Key); 847 end if; 848 849 Vertex := Get_Vertices (Edge.X); 850 851 if Vertex.First = No_Edge then 852 Vertex.First := E; 853 end if; 854 855 Vertex.Last := E; 856 Set_Vertices (Edge.X, Vertex); 857 end loop; 858 859 if Verbose then 860 Put_Reduced_Keys (Output, "Key Table"); 861 Put_Edges (Output, "Edge Table"); 862 Put_Vertex_Table (Output, "Vertex Table"); 863 end if; 864 end if; 865 end Compute_Edges_And_Vertices; 866 867 ------------ 868 -- Define -- 869 ------------ 870 871 procedure Define 872 (Name : Table_Name; 873 Item_Size : out Natural; 874 Length_1 : out Natural; 875 Length_2 : out Natural) 876 is 877 begin 878 case Name is 879 when Character_Position => 880 Item_Size := 8; 881 Length_1 := Char_Pos_Set_Len; 882 Length_2 := 0; 883 884 when Used_Character_Set => 885 Item_Size := 8; 886 Length_1 := 256; 887 Length_2 := 0; 888 889 when Function_Table_1 890 | Function_Table_2 891 => 892 Item_Size := Type_Size (NV); 893 Length_1 := T1_Len; 894 Length_2 := T2_Len; 895 896 when Graph_Table => 897 Item_Size := Type_Size (NK); 898 Length_1 := NV; 899 Length_2 := 0; 900 end case; 901 end Define; 902 903 -------------- 904 -- Finalize -- 905 -------------- 906 907 procedure Finalize is 908 begin 909 if Verbose then 910 Put (Output, "Finalize"); 911 New_Line (Output); 912 end if; 913 914 -- Deallocate all the WT components (both initial and reduced ones) to 915 -- avoid memory leaks. 916 917 for W in 0 .. WT.Last loop 918 919 -- Note: WT.Table (NK) is a temporary variable, do not free it since 920 -- this would cause a double free. 921 922 if W /= NK then 923 Free_Word (WT.Table (W)); 924 end if; 925 end loop; 926 927 WT.Release; 928 IT.Release; 929 930 -- Reset all variables for next usage 931 932 Keys := No_Table; 933 934 Char_Pos_Set := No_Table; 935 Char_Pos_Set_Len := 0; 936 937 Used_Char_Set := No_Table; 938 Used_Char_Set_Len := 0; 939 940 T1 := No_Table; 941 T2 := No_Table; 942 943 T1_Len := 0; 944 T2_Len := 0; 945 946 G := No_Table; 947 G_Len := 0; 948 949 Edges := No_Table; 950 Edges_Len := 0; 951 952 Vertices := No_Table; 953 NV := 0; 954 955 NK := 0; 956 Max_Key_Len := 0; 957 Min_Key_Len := 0; 958 end Finalize; 959 960 ---------------------------- 961 -- Generate_Mapping_Table -- 962 ---------------------------- 963 964 procedure Generate_Mapping_Table 965 (Tab : Integer; 966 L1 : Natural; 967 L2 : Natural; 968 Seed : in out Natural) 969 is 970 begin 971 for J in 0 .. L1 - 1 loop 972 for K in 0 .. L2 - 1 loop 973 Random (Seed); 974 Set_Table (Tab, J, K, Seed mod NV); 975 end loop; 976 end loop; 977 end Generate_Mapping_Table; 978 979 ----------------------------- 980 -- Generate_Mapping_Tables -- 981 ----------------------------- 982 983 procedure Generate_Mapping_Tables 984 (Opt : Optimization; 985 Seed : in out Natural) 986 is 987 begin 988 -- If T1 and T2 are already allocated no need to do it twice. Reuse them 989 -- as their size has not changed. 990 991 if T1 = No_Table and then T2 = No_Table then 992 declare 993 Used_Char_Last : Natural := 0; 994 Used_Char : Natural; 995 996 begin 997 if Opt = CPU_Time then 998 for P in reverse Character'Range loop 999 Used_Char := Get_Used_Char (P); 1000 if Used_Char /= 0 then 1001 Used_Char_Last := Used_Char; 1002 exit; 1003 end if; 1004 end loop; 1005 end if; 1006 1007 T1_Len := Char_Pos_Set_Len; 1008 T2_Len := Used_Char_Last + 1; 1009 T1 := Allocate (T1_Len * T2_Len); 1010 T2 := Allocate (T1_Len * T2_Len); 1011 end; 1012 end if; 1013 1014 Generate_Mapping_Table (T1, T1_Len, T2_Len, Seed); 1015 Generate_Mapping_Table (T2, T1_Len, T2_Len, Seed); 1016 1017 if Verbose then 1018 Put_Used_Char_Set (Output, "Used Character Set"); 1019 Put_Int_Matrix (Output, "Function Table 1", T1, 1020 T1_Len, T2_Len); 1021 Put_Int_Matrix (Output, "Function Table 2", T2, 1022 T1_Len, T2_Len); 1023 end if; 1024 end Generate_Mapping_Tables; 1025 1026 ------------------ 1027 -- Get_Char_Pos -- 1028 ------------------ 1029 1030 function Get_Char_Pos (P : Natural) return Natural is 1031 N : constant Natural := Char_Pos_Set + P; 1032 begin 1033 return IT.Table (N); 1034 end Get_Char_Pos; 1035 1036 --------------- 1037 -- Get_Edges -- 1038 --------------- 1039 1040 function Get_Edges (F : Natural) return Edge_Type is 1041 N : constant Natural := Edges + (F * Edge_Size); 1042 E : Edge_Type; 1043 begin 1044 E.X := IT.Table (N); 1045 E.Y := IT.Table (N + 1); 1046 E.Key := IT.Table (N + 2); 1047 return E; 1048 end Get_Edges; 1049 1050 --------------- 1051 -- Get_Graph -- 1052 --------------- 1053 1054 function Get_Graph (N : Natural) return Integer is 1055 begin 1056 return IT.Table (G + N); 1057 end Get_Graph; 1058 1059 ------------- 1060 -- Get_Key -- 1061 ------------- 1062 1063 function Get_Key (N : Key_Id) return Key_Type is 1064 K : Key_Type; 1065 begin 1066 K.Edge := IT.Table (Keys + N); 1067 return K; 1068 end Get_Key; 1069 1070 --------------- 1071 -- Get_Table -- 1072 --------------- 1073 1074 function Get_Table (T : Integer; X, Y : Natural) return Natural is 1075 N : constant Natural := T + (Y * T1_Len) + X; 1076 begin 1077 return IT.Table (N); 1078 end Get_Table; 1079 1080 ------------------- 1081 -- Get_Used_Char -- 1082 ------------------- 1083 1084 function Get_Used_Char (C : Character) return Natural is 1085 N : constant Natural := Used_Char_Set + Character'Pos (C); 1086 begin 1087 return IT.Table (N); 1088 end Get_Used_Char; 1089 1090 ------------------ 1091 -- Get_Vertices -- 1092 ------------------ 1093 1094 function Get_Vertices (F : Natural) return Vertex_Type is 1095 N : constant Natural := Vertices + (F * Vertex_Size); 1096 V : Vertex_Type; 1097 begin 1098 V.First := IT.Table (N); 1099 V.Last := IT.Table (N + 1); 1100 return V; 1101 end Get_Vertices; 1102 1103 ----------- 1104 -- Image -- 1105 ----------- 1106 1107 function Image (Int : Integer; W : Natural := 0) return String is 1108 B : String (1 .. 32); 1109 L : Natural := 0; 1110 1111 procedure Img (V : Natural); 1112 -- Compute image of V into B, starting at B (L), incrementing L 1113 1114 --------- 1115 -- Img -- 1116 --------- 1117 1118 procedure Img (V : Natural) is 1119 begin 1120 if V > 9 then 1121 Img (V / 10); 1122 end if; 1123 1124 L := L + 1; 1125 B (L) := Character'Val ((V mod 10) + Character'Pos ('0')); 1126 end Img; 1127 1128 -- Start of processing for Image 1129 1130 begin 1131 if Int < 0 then 1132 L := L + 1; 1133 B (L) := '-'; 1134 Img (-Int); 1135 else 1136 Img (Int); 1137 end if; 1138 1139 return Image (B (1 .. L), W); 1140 end Image; 1141 1142 ----------- 1143 -- Image -- 1144 ----------- 1145 1146 function Image (Str : String; W : Natural := 0) return String is 1147 Len : constant Natural := Str'Length; 1148 Max : Natural := Len; 1149 1150 begin 1151 if Max < W then 1152 Max := W; 1153 end if; 1154 1155 declare 1156 Buf : String (1 .. Max) := (1 .. Max => ' '); 1157 1158 begin 1159 for J in 0 .. Len - 1 loop 1160 Buf (Max - Len + 1 + J) := Str (Str'First + J); 1161 end loop; 1162 1163 return Buf; 1164 end; 1165 end Image; 1166 1167 ------------- 1168 -- Initial -- 1169 ------------- 1170 1171 function Initial (K : Key_Id) return Word_Id is 1172 begin 1173 return K; 1174 end Initial; 1175 1176 ---------------- 1177 -- Initialize -- 1178 ---------------- 1179 1180 procedure Initialize 1181 (Seed : Natural; 1182 K_To_V : Float := Default_K_To_V; 1183 Optim : Optimization := Memory_Space; 1184 Tries : Positive := Default_Tries) 1185 is 1186 begin 1187 if Verbose then 1188 Put (Output, "Initialize"); 1189 New_Line (Output); 1190 end if; 1191 1192 -- Deallocate the part of the table concerning the reduced words. 1193 -- Initial words are already present in the table. We may have reduced 1194 -- words already there because a previous computation failed. We are 1195 -- currently retrying and the reduced words have to be deallocated. 1196 1197 for W in Reduced (0) .. WT.Last loop 1198 Free_Word (WT.Table (W)); 1199 end loop; 1200 1201 IT.Init; 1202 1203 -- Initialize of computation variables 1204 1205 Keys := No_Table; 1206 1207 Char_Pos_Set := No_Table; 1208 Char_Pos_Set_Len := 0; 1209 1210 Used_Char_Set := No_Table; 1211 Used_Char_Set_Len := 0; 1212 1213 T1 := No_Table; 1214 T2 := No_Table; 1215 1216 T1_Len := 0; 1217 T2_Len := 0; 1218 1219 G := No_Table; 1220 G_Len := 0; 1221 1222 Edges := No_Table; 1223 Edges_Len := 0; 1224 1225 Vertices := No_Table; 1226 NV := 0; 1227 1228 S := Seed; 1229 K2V := K_To_V; 1230 Opt := Optim; 1231 NT := Tries; 1232 1233 if K2V <= 2.0 then 1234 raise Program_Error with "K to V ratio cannot be lower than 2.0"; 1235 end if; 1236 1237 -- Do not accept a value of K2V too close to 2.0 such that once 1238 -- rounded up, NV = 2 * NK because the algorithm would not converge. 1239 1240 NV := Natural (Float (NK) * K2V); 1241 if NV <= 2 * NK then 1242 NV := 2 * NK + 1; 1243 end if; 1244 1245 Keys := Allocate (NK); 1246 1247 -- Resize initial words to have all of them at the same size 1248 -- (so the size of the largest one). 1249 1250 for K in 0 .. NK - 1 loop 1251 Resize_Word (WT.Table (Initial (K)), Max_Key_Len); 1252 end loop; 1253 1254 -- Allocated the table to store the reduced words. As WT is a 1255 -- GNAT.Table (using C memory management), pointers have to be 1256 -- explicitly initialized to null. 1257 1258 WT.Set_Last (Reduced (NK - 1)); 1259 1260 -- Note: Reduced (0) = NK + 1 1261 1262 WT.Table (NK) := null; 1263 1264 for W in 0 .. NK - 1 loop 1265 WT.Table (Reduced (W)) := null; 1266 end loop; 1267 end Initialize; 1268 1269 ------------ 1270 -- Insert -- 1271 ------------ 1272 1273 procedure Insert (Value : String) is 1274 Len : constant Natural := Value'Length; 1275 1276 begin 1277 if Verbose then 1278 Put (Output, "Inserting """ & Value & """"); 1279 New_Line (Output); 1280 end if; 1281 1282 for J in Value'Range loop 1283 pragma Assert (Value (J) /= ASCII.NUL); 1284 null; 1285 end loop; 1286 1287 WT.Set_Last (NK); 1288 WT.Table (NK) := New_Word (Value); 1289 NK := NK + 1; 1290 1291 if Max_Key_Len < Len then 1292 Max_Key_Len := Len; 1293 end if; 1294 1295 if Min_Key_Len = 0 or else Len < Min_Key_Len then 1296 Min_Key_Len := Len; 1297 end if; 1298 end Insert; 1299 1300 -------------- 1301 -- New_Line -- 1302 -------------- 1303 1304 procedure New_Line (File : File_Descriptor) is 1305 begin 1306 if Write (File, EOL'Address, 1) /= 1 then 1307 raise Program_Error; 1308 end if; 1309 end New_Line; 1310 1311 -------------- 1312 -- New_Word -- 1313 -------------- 1314 1315 function New_Word (S : String) return Word_Type is 1316 begin 1317 return new String'(S); 1318 end New_Word; 1319 1320 ------------------------------ 1321 -- Parse_Position_Selection -- 1322 ------------------------------ 1323 1324 procedure Parse_Position_Selection (Argument : String) is 1325 N : Natural := Argument'First; 1326 L : constant Natural := Argument'Last; 1327 M : constant Natural := Max_Key_Len; 1328 1329 T : array (1 .. M) of Boolean := (others => False); 1330 1331 function Parse_Index return Natural; 1332 -- Parse argument starting at index N to find an index 1333 1334 ----------------- 1335 -- Parse_Index -- 1336 ----------------- 1337 1338 function Parse_Index return Natural is 1339 C : Character := Argument (N); 1340 V : Natural := 0; 1341 1342 begin 1343 if C = '$' then 1344 N := N + 1; 1345 return M; 1346 end if; 1347 1348 if C not in '0' .. '9' then 1349 raise Program_Error with "cannot read position argument"; 1350 end if; 1351 1352 while C in '0' .. '9' loop 1353 V := V * 10 + (Character'Pos (C) - Character'Pos ('0')); 1354 N := N + 1; 1355 exit when L < N; 1356 C := Argument (N); 1357 end loop; 1358 1359 return V; 1360 end Parse_Index; 1361 1362 -- Start of processing for Parse_Position_Selection 1363 1364 begin 1365 -- Empty specification means all the positions 1366 1367 if L < N then 1368 Char_Pos_Set_Len := M; 1369 Char_Pos_Set := Allocate (Char_Pos_Set_Len); 1370 1371 for C in 0 .. Char_Pos_Set_Len - 1 loop 1372 Set_Char_Pos (C, C + 1); 1373 end loop; 1374 1375 else 1376 loop 1377 declare 1378 First, Last : Natural; 1379 1380 begin 1381 First := Parse_Index; 1382 Last := First; 1383 1384 -- Detect a range 1385 1386 if N <= L and then Argument (N) = '-' then 1387 N := N + 1; 1388 Last := Parse_Index; 1389 end if; 1390 1391 -- Include the positions in the selection 1392 1393 for J in First .. Last loop 1394 T (J) := True; 1395 end loop; 1396 end; 1397 1398 exit when L < N; 1399 1400 if Argument (N) /= ',' then 1401 raise Program_Error with "cannot read position argument"; 1402 end if; 1403 1404 N := N + 1; 1405 end loop; 1406 1407 -- Compute position selection length 1408 1409 N := 0; 1410 for J in T'Range loop 1411 if T (J) then 1412 N := N + 1; 1413 end if; 1414 end loop; 1415 1416 -- Fill position selection 1417 1418 Char_Pos_Set_Len := N; 1419 Char_Pos_Set := Allocate (Char_Pos_Set_Len); 1420 1421 N := 0; 1422 for J in T'Range loop 1423 if T (J) then 1424 Set_Char_Pos (N, J); 1425 N := N + 1; 1426 end if; 1427 end loop; 1428 end if; 1429 end Parse_Position_Selection; 1430 1431 ------------- 1432 -- Produce -- 1433 ------------- 1434 1435 procedure Produce 1436 (Pkg_Name : String := Default_Pkg_Name; 1437 Use_Stdout : Boolean := False) 1438 is 1439 File : File_Descriptor := Standout; 1440 1441 Status : Boolean; 1442 -- For call to Close 1443 1444 function Array_Img (N, T, R1 : String; R2 : String := "") return String; 1445 -- Return string "N : constant array (R1[, R2]) of T;" 1446 1447 function Range_Img (F, L : Natural; T : String := "") return String; 1448 -- Return string "[T range ]F .. L" 1449 1450 function Type_Img (L : Natural) return String; 1451 -- Return the larger unsigned type T such that T'Last < L 1452 1453 --------------- 1454 -- Array_Img -- 1455 --------------- 1456 1457 function Array_Img 1458 (N, T, R1 : String; 1459 R2 : String := "") return String 1460 is 1461 begin 1462 Last := 0; 1463 Add (" "); 1464 Add (N); 1465 Add (" : constant array ("); 1466 Add (R1); 1467 1468 if R2 /= "" then 1469 Add (", "); 1470 Add (R2); 1471 end if; 1472 1473 Add (") of "); 1474 Add (T); 1475 Add (" :="); 1476 return Line (1 .. Last); 1477 end Array_Img; 1478 1479 --------------- 1480 -- Range_Img -- 1481 --------------- 1482 1483 function Range_Img (F, L : Natural; T : String := "") return String is 1484 FI : constant String := Image (F); 1485 FL : constant Natural := FI'Length; 1486 LI : constant String := Image (L); 1487 LL : constant Natural := LI'Length; 1488 TL : constant Natural := T'Length; 1489 RI : String (1 .. TL + 7 + FL + 4 + LL); 1490 Len : Natural := 0; 1491 1492 begin 1493 if TL /= 0 then 1494 RI (Len + 1 .. Len + TL) := T; 1495 Len := Len + TL; 1496 RI (Len + 1 .. Len + 7) := " range "; 1497 Len := Len + 7; 1498 end if; 1499 1500 RI (Len + 1 .. Len + FL) := FI; 1501 Len := Len + FL; 1502 RI (Len + 1 .. Len + 4) := " .. "; 1503 Len := Len + 4; 1504 RI (Len + 1 .. Len + LL) := LI; 1505 Len := Len + LL; 1506 return RI (1 .. Len); 1507 end Range_Img; 1508 1509 -------------- 1510 -- Type_Img -- 1511 -------------- 1512 1513 function Type_Img (L : Natural) return String is 1514 S : constant String := Image (Type_Size (L)); 1515 U : String := "Unsigned_ "; 1516 N : Natural := 9; 1517 1518 begin 1519 for J in S'Range loop 1520 N := N + 1; 1521 U (N) := S (J); 1522 end loop; 1523 1524 return U (1 .. N); 1525 end Type_Img; 1526 1527 F : Natural; 1528 L : Natural; 1529 P : Natural; 1530 1531 FName : String := Ada_File_Base_Name (Pkg_Name) & ".ads"; 1532 -- Initially, the name of the spec file, then modified to be the name of 1533 -- the body file. Not used if Use_Stdout is True. 1534 1535 -- Start of processing for Produce 1536 1537 begin 1538 1539 if Verbose and then not Use_Stdout then 1540 Put (Output, 1541 "Producing " & Ada.Directories.Current_Directory & "/" & FName); 1542 New_Line (Output); 1543 end if; 1544 1545 if not Use_Stdout then 1546 File := Create_File (FName, Binary); 1547 1548 if File = Invalid_FD then 1549 raise Program_Error with "cannot create: " & FName; 1550 end if; 1551 end if; 1552 1553 Put (File, "package "); 1554 Put (File, Pkg_Name); 1555 Put (File, " is"); 1556 New_Line (File); 1557 Put (File, " function Hash (S : String) return Natural;"); 1558 New_Line (File); 1559 Put (File, "end "); 1560 Put (File, Pkg_Name); 1561 Put (File, ";"); 1562 New_Line (File); 1563 1564 if not Use_Stdout then 1565 Close (File, Status); 1566 1567 if not Status then 1568 raise Device_Error; 1569 end if; 1570 end if; 1571 1572 if not Use_Stdout then 1573 1574 -- Set to body file name 1575 1576 FName (FName'Last) := 'b'; 1577 1578 File := Create_File (FName, Binary); 1579 1580 if File = Invalid_FD then 1581 raise Program_Error with "cannot create: " & FName; 1582 end if; 1583 end if; 1584 1585 Put (File, "with Interfaces; use Interfaces;"); 1586 New_Line (File); 1587 New_Line (File); 1588 Put (File, "package body "); 1589 Put (File, Pkg_Name); 1590 Put (File, " is"); 1591 New_Line (File); 1592 New_Line (File); 1593 1594 if Opt = CPU_Time then 1595 Put (File, Array_Img ("C", Type_Img (256), "Character")); 1596 New_Line (File); 1597 1598 F := Character'Pos (Character'First); 1599 L := Character'Pos (Character'Last); 1600 1601 for J in Character'Range loop 1602 P := Get_Used_Char (J); 1603 Put (File, Image (P), 1, 0, 1, F, L, Character'Pos (J)); 1604 end loop; 1605 1606 New_Line (File); 1607 end if; 1608 1609 F := 0; 1610 L := Char_Pos_Set_Len - 1; 1611 1612 Put (File, Array_Img ("P", "Natural", Range_Img (F, L))); 1613 New_Line (File); 1614 1615 for J in F .. L loop 1616 Put (File, Image (Get_Char_Pos (J)), 1, 0, 1, F, L, J); 1617 end loop; 1618 1619 New_Line (File); 1620 1621 case Opt is 1622 when CPU_Time => 1623 Put_Int_Matrix 1624 (File, 1625 Array_Img ("T1", Type_Img (NV), 1626 Range_Img (0, T1_Len - 1), 1627 Range_Img (0, T2_Len - 1, Type_Img (256))), 1628 T1, T1_Len, T2_Len); 1629 1630 when Memory_Space => 1631 Put_Int_Matrix 1632 (File, 1633 Array_Img ("T1", Type_Img (NV), 1634 Range_Img (0, T1_Len - 1)), 1635 T1, T1_Len, 0); 1636 end case; 1637 1638 New_Line (File); 1639 1640 case Opt is 1641 when CPU_Time => 1642 Put_Int_Matrix 1643 (File, 1644 Array_Img ("T2", Type_Img (NV), 1645 Range_Img (0, T1_Len - 1), 1646 Range_Img (0, T2_Len - 1, Type_Img (256))), 1647 T2, T1_Len, T2_Len); 1648 1649 when Memory_Space => 1650 Put_Int_Matrix 1651 (File, 1652 Array_Img ("T2", Type_Img (NV), 1653 Range_Img (0, T1_Len - 1)), 1654 T2, T1_Len, 0); 1655 end case; 1656 1657 New_Line (File); 1658 1659 Put_Int_Vector 1660 (File, 1661 Array_Img ("G", Type_Img (NK), 1662 Range_Img (0, G_Len - 1)), 1663 G, G_Len); 1664 New_Line (File); 1665 1666 Put (File, " function Hash (S : String) return Natural is"); 1667 New_Line (File); 1668 Put (File, " F : constant Natural := S'First - 1;"); 1669 New_Line (File); 1670 Put (File, " L : constant Natural := S'Length;"); 1671 New_Line (File); 1672 Put (File, " F1, F2 : Natural := 0;"); 1673 New_Line (File); 1674 1675 Put (File, " J : "); 1676 1677 case Opt is 1678 when CPU_Time => 1679 Put (File, Type_Img (256)); 1680 1681 when Memory_Space => 1682 Put (File, "Natural"); 1683 end case; 1684 1685 Put (File, ";"); 1686 New_Line (File); 1687 1688 Put (File, " begin"); 1689 New_Line (File); 1690 Put (File, " for K in P'Range loop"); 1691 New_Line (File); 1692 Put (File, " exit when L < P (K);"); 1693 New_Line (File); 1694 Put (File, " J := "); 1695 1696 case Opt is 1697 when CPU_Time => 1698 Put (File, "C"); 1699 1700 when Memory_Space => 1701 Put (File, "Character'Pos"); 1702 end case; 1703 1704 Put (File, " (S (P (K) + F));"); 1705 New_Line (File); 1706 1707 Put (File, " F1 := (F1 + Natural (T1 (K"); 1708 1709 if Opt = CPU_Time then 1710 Put (File, ", J"); 1711 end if; 1712 1713 Put (File, "))"); 1714 1715 if Opt = Memory_Space then 1716 Put (File, " * J"); 1717 end if; 1718 1719 Put (File, ") mod "); 1720 Put (File, Image (NV)); 1721 Put (File, ";"); 1722 New_Line (File); 1723 1724 Put (File, " F2 := (F2 + Natural (T2 (K"); 1725 1726 if Opt = CPU_Time then 1727 Put (File, ", J"); 1728 end if; 1729 1730 Put (File, "))"); 1731 1732 if Opt = Memory_Space then 1733 Put (File, " * J"); 1734 end if; 1735 1736 Put (File, ") mod "); 1737 Put (File, Image (NV)); 1738 Put (File, ";"); 1739 New_Line (File); 1740 1741 Put (File, " end loop;"); 1742 New_Line (File); 1743 1744 Put (File, 1745 " return (Natural (G (F1)) + Natural (G (F2))) mod "); 1746 1747 Put (File, Image (NK)); 1748 Put (File, ";"); 1749 New_Line (File); 1750 Put (File, " end Hash;"); 1751 New_Line (File); 1752 New_Line (File); 1753 Put (File, "end "); 1754 Put (File, Pkg_Name); 1755 Put (File, ";"); 1756 New_Line (File); 1757 1758 if not Use_Stdout then 1759 Close (File, Status); 1760 1761 if not Status then 1762 raise Device_Error; 1763 end if; 1764 end if; 1765 end Produce; 1766 1767 --------- 1768 -- Put -- 1769 --------- 1770 1771 procedure Put (File : File_Descriptor; Str : String) is 1772 Len : constant Natural := Str'Length; 1773 begin 1774 for J in Str'Range loop 1775 pragma Assert (Str (J) /= ASCII.NUL); 1776 null; 1777 end loop; 1778 1779 if Write (File, Str'Address, Len) /= Len then 1780 raise Program_Error; 1781 end if; 1782 end Put; 1783 1784 --------- 1785 -- Put -- 1786 --------- 1787 1788 procedure Put 1789 (F : File_Descriptor; 1790 S : String; 1791 F1 : Natural; 1792 L1 : Natural; 1793 C1 : Natural; 1794 F2 : Natural; 1795 L2 : Natural; 1796 C2 : Natural) 1797 is 1798 Len : constant Natural := S'Length; 1799 1800 procedure Flush; 1801 -- Write current line, followed by LF 1802 1803 ----------- 1804 -- Flush -- 1805 ----------- 1806 1807 procedure Flush is 1808 begin 1809 Put (F, Line (1 .. Last)); 1810 New_Line (F); 1811 Last := 0; 1812 end Flush; 1813 1814 -- Start of processing for Put 1815 1816 begin 1817 if C1 = F1 and then C2 = F2 then 1818 Last := 0; 1819 end if; 1820 1821 if Last + Len + 3 >= Max then 1822 Flush; 1823 end if; 1824 1825 if Last = 0 then 1826 Add (" "); 1827 1828 if F1 <= L1 then 1829 if C1 = F1 and then C2 = F2 then 1830 Add ('('); 1831 1832 if F1 = L1 then 1833 Add ("0 .. 0 => "); 1834 end if; 1835 1836 else 1837 Add (' '); 1838 end if; 1839 end if; 1840 end if; 1841 1842 if C2 = F2 then 1843 Add ('('); 1844 1845 if F2 = L2 then 1846 Add ("0 .. 0 => "); 1847 end if; 1848 1849 else 1850 Add (' '); 1851 end if; 1852 1853 Add (S); 1854 1855 if C2 = L2 then 1856 Add (')'); 1857 1858 if F1 > L1 then 1859 Add (';'); 1860 Flush; 1861 1862 elsif C1 /= L1 then 1863 Add (','); 1864 Flush; 1865 1866 else 1867 Add (')'); 1868 Add (';'); 1869 Flush; 1870 end if; 1871 1872 else 1873 Add (','); 1874 end if; 1875 end Put; 1876 1877 --------------- 1878 -- Put_Edges -- 1879 --------------- 1880 1881 procedure Put_Edges (File : File_Descriptor; Title : String) is 1882 E : Edge_Type; 1883 F1 : constant Natural := 1; 1884 L1 : constant Natural := Edges_Len - 1; 1885 M : constant Natural := Max / 5; 1886 1887 begin 1888 Put (File, Title); 1889 New_Line (File); 1890 1891 -- Edges valid range is 1 .. Edge_Len - 1 1892 1893 for J in F1 .. L1 loop 1894 E := Get_Edges (J); 1895 Put (File, Image (J, M), F1, L1, J, 1, 4, 1); 1896 Put (File, Image (E.X, M), F1, L1, J, 1, 4, 2); 1897 Put (File, Image (E.Y, M), F1, L1, J, 1, 4, 3); 1898 Put (File, Image (E.Key, M), F1, L1, J, 1, 4, 4); 1899 end loop; 1900 end Put_Edges; 1901 1902 ---------------------- 1903 -- Put_Initial_Keys -- 1904 ---------------------- 1905 1906 procedure Put_Initial_Keys (File : File_Descriptor; Title : String) is 1907 F1 : constant Natural := 0; 1908 L1 : constant Natural := NK - 1; 1909 M : constant Natural := Max / 5; 1910 K : Key_Type; 1911 1912 begin 1913 Put (File, Title); 1914 New_Line (File); 1915 1916 for J in F1 .. L1 loop 1917 K := Get_Key (J); 1918 Put (File, Image (J, M), F1, L1, J, 1, 3, 1); 1919 Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); 1920 Put (File, Trim_Trailing_Nuls (WT.Table (Initial (J)).all), 1921 F1, L1, J, 1, 3, 3); 1922 end loop; 1923 end Put_Initial_Keys; 1924 1925 -------------------- 1926 -- Put_Int_Matrix -- 1927 -------------------- 1928 1929 procedure Put_Int_Matrix 1930 (File : File_Descriptor; 1931 Title : String; 1932 Table : Integer; 1933 Len_1 : Natural; 1934 Len_2 : Natural) 1935 is 1936 F1 : constant Integer := 0; 1937 L1 : constant Integer := Len_1 - 1; 1938 F2 : constant Integer := 0; 1939 L2 : constant Integer := Len_2 - 1; 1940 Ix : Natural; 1941 1942 begin 1943 Put (File, Title); 1944 New_Line (File); 1945 1946 if Len_2 = 0 then 1947 for J in F1 .. L1 loop 1948 Ix := IT.Table (Table + J); 1949 Put (File, Image (Ix), 1, 0, 1, F1, L1, J); 1950 end loop; 1951 1952 else 1953 for J in F1 .. L1 loop 1954 for K in F2 .. L2 loop 1955 Ix := IT.Table (Table + J + K * Len_1); 1956 Put (File, Image (Ix), F1, L1, J, F2, L2, K); 1957 end loop; 1958 end loop; 1959 end if; 1960 end Put_Int_Matrix; 1961 1962 -------------------- 1963 -- Put_Int_Vector -- 1964 -------------------- 1965 1966 procedure Put_Int_Vector 1967 (File : File_Descriptor; 1968 Title : String; 1969 Vector : Integer; 1970 Length : Natural) 1971 is 1972 F2 : constant Natural := 0; 1973 L2 : constant Natural := Length - 1; 1974 1975 begin 1976 Put (File, Title); 1977 New_Line (File); 1978 1979 for J in F2 .. L2 loop 1980 Put (File, Image (IT.Table (Vector + J)), 1, 0, 1, F2, L2, J); 1981 end loop; 1982 end Put_Int_Vector; 1983 1984 ---------------------- 1985 -- Put_Reduced_Keys -- 1986 ---------------------- 1987 1988 procedure Put_Reduced_Keys (File : File_Descriptor; Title : String) is 1989 F1 : constant Natural := 0; 1990 L1 : constant Natural := NK - 1; 1991 M : constant Natural := Max / 5; 1992 K : Key_Type; 1993 1994 begin 1995 Put (File, Title); 1996 New_Line (File); 1997 1998 for J in F1 .. L1 loop 1999 K := Get_Key (J); 2000 Put (File, Image (J, M), F1, L1, J, 1, 3, 1); 2001 Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); 2002 Put (File, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all), 2003 F1, L1, J, 1, 3, 3); 2004 end loop; 2005 end Put_Reduced_Keys; 2006 2007 ----------------------- 2008 -- Put_Used_Char_Set -- 2009 ----------------------- 2010 2011 procedure Put_Used_Char_Set (File : File_Descriptor; Title : String) is 2012 F : constant Natural := Character'Pos (Character'First); 2013 L : constant Natural := Character'Pos (Character'Last); 2014 2015 begin 2016 Put (File, Title); 2017 New_Line (File); 2018 2019 for J in Character'Range loop 2020 Put 2021 (File, Image (Get_Used_Char (J)), 1, 0, 1, F, L, Character'Pos (J)); 2022 end loop; 2023 end Put_Used_Char_Set; 2024 2025 ---------------------- 2026 -- Put_Vertex_Table -- 2027 ---------------------- 2028 2029 procedure Put_Vertex_Table (File : File_Descriptor; Title : String) is 2030 F1 : constant Natural := 0; 2031 L1 : constant Natural := NV - 1; 2032 M : constant Natural := Max / 4; 2033 V : Vertex_Type; 2034 2035 begin 2036 Put (File, Title); 2037 New_Line (File); 2038 2039 for J in F1 .. L1 loop 2040 V := Get_Vertices (J); 2041 Put (File, Image (J, M), F1, L1, J, 1, 3, 1); 2042 Put (File, Image (V.First, M), F1, L1, J, 1, 3, 2); 2043 Put (File, Image (V.Last, M), F1, L1, J, 1, 3, 3); 2044 end loop; 2045 end Put_Vertex_Table; 2046 2047 ------------ 2048 -- Random -- 2049 ------------ 2050 2051 procedure Random (Seed : in out Natural) is 2052 2053 -- Park & Miller Standard Minimal using Schrage's algorithm to avoid 2054 -- overflow: Xn+1 = 16807 * Xn mod (2 ** 31 - 1) 2055 2056 R : Natural; 2057 Q : Natural; 2058 X : Integer; 2059 2060 begin 2061 R := Seed mod 127773; 2062 Q := Seed / 127773; 2063 X := 16807 * R - 2836 * Q; 2064 2065 Seed := (if X < 0 then X + 2147483647 else X); 2066 end Random; 2067 2068 ------------- 2069 -- Reduced -- 2070 ------------- 2071 2072 function Reduced (K : Key_Id) return Word_Id is 2073 begin 2074 return K + NK + 1; 2075 end Reduced; 2076 2077 ----------------- 2078 -- Resize_Word -- 2079 ----------------- 2080 2081 procedure Resize_Word (W : in out Word_Type; Len : Natural) is 2082 S1 : constant String := W.all; 2083 S2 : String (1 .. Len) := (others => ASCII.NUL); 2084 L : constant Natural := S1'Length; 2085 begin 2086 if L /= Len then 2087 Free_Word (W); 2088 S2 (1 .. L) := S1; 2089 W := New_Word (S2); 2090 end if; 2091 end Resize_Word; 2092 2093 -------------------------- 2094 -- Select_Char_Position -- 2095 -------------------------- 2096 2097 procedure Select_Char_Position is 2098 2099 type Vertex_Table_Type is array (Natural range <>) of Vertex_Type; 2100 2101 procedure Build_Identical_Keys_Sets 2102 (Table : in out Vertex_Table_Type; 2103 Last : in out Natural; 2104 Pos : Natural); 2105 -- Build a list of keys subsets that are identical with the current 2106 -- position selection plus Pos. Once this routine is called, reduced 2107 -- words are sorted by subsets and each item (First, Last) in Sets 2108 -- defines the range of identical keys. 2109 -- Need comment saying exactly what Last is ??? 2110 2111 function Count_Different_Keys 2112 (Table : Vertex_Table_Type; 2113 Last : Natural; 2114 Pos : Natural) return Natural; 2115 -- For each subset in Sets, count the number of different keys if we add 2116 -- Pos to the current position selection. 2117 2118 Sel_Position : IT.Table_Type (1 .. Max_Key_Len); 2119 Last_Sel_Pos : Natural := 0; 2120 Max_Sel_Pos : Natural := 0; 2121 2122 ------------------------------- 2123 -- Build_Identical_Keys_Sets -- 2124 ------------------------------- 2125 2126 procedure Build_Identical_Keys_Sets 2127 (Table : in out Vertex_Table_Type; 2128 Last : in out Natural; 2129 Pos : Natural) 2130 is 2131 S : constant Vertex_Table_Type := Table (Table'First .. Last); 2132 C : constant Natural := Pos; 2133 -- Shortcuts (why are these not renames ???) 2134 2135 F : Integer; 2136 L : Integer; 2137 -- First and last words of a subset 2138 2139 Offset : Natural; 2140 -- GNAT.Heap_Sort assumes that the first array index is 1. Offset 2141 -- defines the translation to operate. 2142 2143 function Lt (L, R : Natural) return Boolean; 2144 procedure Move (From : Natural; To : Natural); 2145 -- Subprograms needed by GNAT.Heap_Sort_G 2146 2147 -------- 2148 -- Lt -- 2149 -------- 2150 2151 function Lt (L, R : Natural) return Boolean is 2152 C : constant Natural := Pos; 2153 Left : Natural; 2154 Right : Natural; 2155 2156 begin 2157 if L = 0 then 2158 Left := NK; 2159 Right := Offset + R; 2160 elsif R = 0 then 2161 Left := Offset + L; 2162 Right := NK; 2163 else 2164 Left := Offset + L; 2165 Right := Offset + R; 2166 end if; 2167 2168 return WT.Table (Left)(C) < WT.Table (Right)(C); 2169 end Lt; 2170 2171 ---------- 2172 -- Move -- 2173 ---------- 2174 2175 procedure Move (From : Natural; To : Natural) is 2176 Target, Source : Natural; 2177 2178 begin 2179 if From = 0 then 2180 Source := NK; 2181 Target := Offset + To; 2182 elsif To = 0 then 2183 Source := Offset + From; 2184 Target := NK; 2185 else 2186 Source := Offset + From; 2187 Target := Offset + To; 2188 end if; 2189 2190 WT.Table (Target) := WT.Table (Source); 2191 WT.Table (Source) := null; 2192 end Move; 2193 2194 package Sorting is new GNAT.Heap_Sort_G (Move, Lt); 2195 2196 -- Start of processing for Build_Identical_Key_Sets 2197 2198 begin 2199 Last := 0; 2200 2201 -- For each subset in S, extract the new subsets we have by adding C 2202 -- in the position selection. 2203 2204 for J in S'Range loop 2205 pragma Annotate (CodePeer, Modified, S (J)); 2206 2207 if S (J).First = S (J).Last then 2208 F := S (J).First; 2209 L := S (J).Last; 2210 Last := Last + 1; 2211 Table (Last) := (F, L); 2212 2213 else 2214 Offset := Reduced (S (J).First) - 1; 2215 Sorting.Sort (S (J).Last - S (J).First + 1); 2216 2217 F := S (J).First; 2218 L := F; 2219 for N in S (J).First .. S (J).Last loop 2220 2221 -- For the last item, close the last subset 2222 2223 if N = S (J).Last then 2224 Last := Last + 1; 2225 Table (Last) := (F, N); 2226 2227 -- Two contiguous words are identical when they have the 2228 -- same Cth character. 2229 2230 elsif WT.Table (Reduced (N))(C) = 2231 WT.Table (Reduced (N + 1))(C) 2232 then 2233 L := N + 1; 2234 2235 -- Find a new subset of identical keys. Store the current 2236 -- one and create a new subset. 2237 2238 else 2239 Last := Last + 1; 2240 Table (Last) := (F, L); 2241 F := N + 1; 2242 L := F; 2243 end if; 2244 end loop; 2245 end if; 2246 end loop; 2247 end Build_Identical_Keys_Sets; 2248 2249 -------------------------- 2250 -- Count_Different_Keys -- 2251 -------------------------- 2252 2253 function Count_Different_Keys 2254 (Table : Vertex_Table_Type; 2255 Last : Natural; 2256 Pos : Natural) return Natural 2257 is 2258 N : array (Character) of Natural; 2259 C : Character; 2260 T : Natural := 0; 2261 2262 begin 2263 -- For each subset, count the number of words that are still 2264 -- different when we include Pos in the position selection. Only 2265 -- focus on this position as the other positions already produce 2266 -- identical keys. 2267 2268 for S in 1 .. Last loop 2269 2270 -- Count the occurrences of the different characters 2271 2272 N := (others => 0); 2273 for K in Table (S).First .. Table (S).Last loop 2274 C := WT.Table (Reduced (K))(Pos); 2275 N (C) := N (C) + 1; 2276 end loop; 2277 2278 -- Update the number of different keys. Each character used 2279 -- denotes a different key. 2280 2281 for J in N'Range loop 2282 if N (J) > 0 then 2283 T := T + 1; 2284 end if; 2285 end loop; 2286 end loop; 2287 2288 return T; 2289 end Count_Different_Keys; 2290 2291 -- Start of processing for Select_Char_Position 2292 2293 begin 2294 -- Initialize the reduced words set 2295 2296 for K in 0 .. NK - 1 loop 2297 WT.Table (Reduced (K)) := New_Word (WT.Table (Initial (K)).all); 2298 end loop; 2299 2300 declare 2301 Differences : Natural; 2302 Max_Differences : Natural := 0; 2303 Old_Differences : Natural; 2304 Max_Diff_Sel_Pos : Natural := 0; -- init to kill warning 2305 Max_Diff_Sel_Pos_Idx : Natural := 0; -- init to kill warning 2306 Same_Keys_Sets_Table : Vertex_Table_Type (1 .. NK); 2307 Same_Keys_Sets_Last : Natural := 1; 2308 2309 begin 2310 for C in Sel_Position'Range loop 2311 Sel_Position (C) := C; 2312 end loop; 2313 2314 Same_Keys_Sets_Table (1) := (0, NK - 1); 2315 2316 loop 2317 -- Preserve maximum number of different keys and check later on 2318 -- that this value is strictly incrementing. Otherwise, it means 2319 -- that two keys are strictly identical. 2320 2321 Old_Differences := Max_Differences; 2322 2323 -- The first position should not exceed the minimum key length. 2324 -- Otherwise, we may end up with an empty word once reduced. 2325 2326 Max_Sel_Pos := 2327 (if Last_Sel_Pos = 0 then Min_Key_Len else Max_Key_Len); 2328 2329 -- Find which position increases more the number of differences 2330 2331 for J in Last_Sel_Pos + 1 .. Max_Sel_Pos loop 2332 Differences := Count_Different_Keys 2333 (Same_Keys_Sets_Table, 2334 Same_Keys_Sets_Last, 2335 Sel_Position (J)); 2336 2337 if Verbose then 2338 Put (Output, 2339 "Selecting position" & Sel_Position (J)'Img & 2340 " results in" & Differences'Img & 2341 " differences"); 2342 New_Line (Output); 2343 end if; 2344 2345 if Differences > Max_Differences then 2346 Max_Differences := Differences; 2347 Max_Diff_Sel_Pos := Sel_Position (J); 2348 Max_Diff_Sel_Pos_Idx := J; 2349 end if; 2350 end loop; 2351 2352 if Old_Differences = Max_Differences then 2353 raise Program_Error with "some keys are identical"; 2354 end if; 2355 2356 -- Insert selected position and sort Sel_Position table 2357 2358 Last_Sel_Pos := Last_Sel_Pos + 1; 2359 Sel_Position (Last_Sel_Pos + 1 .. Max_Diff_Sel_Pos_Idx) := 2360 Sel_Position (Last_Sel_Pos .. Max_Diff_Sel_Pos_Idx - 1); 2361 Sel_Position (Last_Sel_Pos) := Max_Diff_Sel_Pos; 2362 2363 for P in 1 .. Last_Sel_Pos - 1 loop 2364 if Max_Diff_Sel_Pos < Sel_Position (P) then 2365 pragma Annotate 2366 (CodePeer, False_Positive, 2367 "test always false", "false positive?"); 2368 2369 Sel_Position (P + 1 .. Last_Sel_Pos) := 2370 Sel_Position (P .. Last_Sel_Pos - 1); 2371 Sel_Position (P) := Max_Diff_Sel_Pos; 2372 exit; 2373 end if; 2374 end loop; 2375 2376 exit when Max_Differences = NK; 2377 2378 Build_Identical_Keys_Sets 2379 (Same_Keys_Sets_Table, 2380 Same_Keys_Sets_Last, 2381 Max_Diff_Sel_Pos); 2382 2383 if Verbose then 2384 Put (Output, 2385 "Selecting position" & Max_Diff_Sel_Pos'Img & 2386 " results in" & Max_Differences'Img & 2387 " differences"); 2388 New_Line (Output); 2389 Put (Output, "--"); 2390 New_Line (Output); 2391 for J in 1 .. Same_Keys_Sets_Last loop 2392 for K in 2393 Same_Keys_Sets_Table (J).First .. 2394 Same_Keys_Sets_Table (J).Last 2395 loop 2396 Put (Output, 2397 Trim_Trailing_Nuls (WT.Table (Reduced (K)).all)); 2398 New_Line (Output); 2399 end loop; 2400 Put (Output, "--"); 2401 New_Line (Output); 2402 end loop; 2403 end if; 2404 end loop; 2405 end; 2406 2407 Char_Pos_Set_Len := Last_Sel_Pos; 2408 Char_Pos_Set := Allocate (Char_Pos_Set_Len); 2409 2410 for C in 1 .. Last_Sel_Pos loop 2411 Set_Char_Pos (C - 1, Sel_Position (C)); 2412 end loop; 2413 end Select_Char_Position; 2414 2415 -------------------------- 2416 -- Select_Character_Set -- 2417 -------------------------- 2418 2419 procedure Select_Character_Set is 2420 Last : Natural := 0; 2421 Used : array (Character) of Boolean := (others => False); 2422 Char : Character; 2423 2424 begin 2425 for J in 0 .. NK - 1 loop 2426 for K in 0 .. Char_Pos_Set_Len - 1 loop 2427 Char := WT.Table (Initial (J))(Get_Char_Pos (K)); 2428 exit when Char = ASCII.NUL; 2429 Used (Char) := True; 2430 end loop; 2431 end loop; 2432 2433 Used_Char_Set_Len := 256; 2434 Used_Char_Set := Allocate (Used_Char_Set_Len); 2435 2436 for J in Used'Range loop 2437 if Used (J) then 2438 Set_Used_Char (J, Last); 2439 Last := Last + 1; 2440 else 2441 Set_Used_Char (J, 0); 2442 end if; 2443 end loop; 2444 end Select_Character_Set; 2445 2446 ------------------ 2447 -- Set_Char_Pos -- 2448 ------------------ 2449 2450 procedure Set_Char_Pos (P : Natural; Item : Natural) is 2451 N : constant Natural := Char_Pos_Set + P; 2452 begin 2453 IT.Table (N) := Item; 2454 end Set_Char_Pos; 2455 2456 --------------- 2457 -- Set_Edges -- 2458 --------------- 2459 2460 procedure Set_Edges (F : Natural; Item : Edge_Type) is 2461 N : constant Natural := Edges + (F * Edge_Size); 2462 begin 2463 IT.Table (N) := Item.X; 2464 IT.Table (N + 1) := Item.Y; 2465 IT.Table (N + 2) := Item.Key; 2466 end Set_Edges; 2467 2468 --------------- 2469 -- Set_Graph -- 2470 --------------- 2471 2472 procedure Set_Graph (N : Natural; Item : Integer) is 2473 begin 2474 IT.Table (G + N) := Item; 2475 end Set_Graph; 2476 2477 ------------- 2478 -- Set_Key -- 2479 ------------- 2480 2481 procedure Set_Key (N : Key_Id; Item : Key_Type) is 2482 begin 2483 IT.Table (Keys + N) := Item.Edge; 2484 end Set_Key; 2485 2486 --------------- 2487 -- Set_Table -- 2488 --------------- 2489 2490 procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural) is 2491 N : constant Natural := T + ((Y * T1_Len) + X); 2492 begin 2493 IT.Table (N) := Item; 2494 end Set_Table; 2495 2496 ------------------- 2497 -- Set_Used_Char -- 2498 ------------------- 2499 2500 procedure Set_Used_Char (C : Character; Item : Natural) is 2501 N : constant Natural := Used_Char_Set + Character'Pos (C); 2502 begin 2503 IT.Table (N) := Item; 2504 end Set_Used_Char; 2505 2506 ------------------ 2507 -- Set_Vertices -- 2508 ------------------ 2509 2510 procedure Set_Vertices (F : Natural; Item : Vertex_Type) is 2511 N : constant Natural := Vertices + (F * Vertex_Size); 2512 begin 2513 IT.Table (N) := Item.First; 2514 IT.Table (N + 1) := Item.Last; 2515 end Set_Vertices; 2516 2517 --------- 2518 -- Sum -- 2519 --------- 2520 2521 function Sum 2522 (Word : Word_Type; 2523 Table : Table_Id; 2524 Opt : Optimization) return Natural 2525 is 2526 S : Natural := 0; 2527 R : Natural; 2528 2529 begin 2530 case Opt is 2531 when CPU_Time => 2532 for J in 0 .. T1_Len - 1 loop 2533 exit when Word (J + 1) = ASCII.NUL; 2534 R := Get_Table (Table, J, Get_Used_Char (Word (J + 1))); 2535 pragma Assert (NV /= 0); 2536 S := (S + R) mod NV; 2537 end loop; 2538 2539 when Memory_Space => 2540 for J in 0 .. T1_Len - 1 loop 2541 exit when Word (J + 1) = ASCII.NUL; 2542 R := Get_Table (Table, J, 0); 2543 pragma Assert (NV /= 0); 2544 S := (S + R * Character'Pos (Word (J + 1))) mod NV; 2545 end loop; 2546 end case; 2547 2548 return S; 2549 end Sum; 2550 2551 ------------------------ 2552 -- Trim_Trailing_Nuls -- 2553 ------------------------ 2554 2555 function Trim_Trailing_Nuls (Str : String) return String is 2556 begin 2557 for J in reverse Str'Range loop 2558 if Str (J) /= ASCII.NUL then 2559 return Str (Str'First .. J); 2560 end if; 2561 end loop; 2562 2563 return Str; 2564 end Trim_Trailing_Nuls; 2565 2566 --------------- 2567 -- Type_Size -- 2568 --------------- 2569 2570 function Type_Size (L : Natural) return Natural is 2571 begin 2572 if L <= 2 ** 8 then 2573 return 8; 2574 elsif L <= 2 ** 16 then 2575 return 16; 2576 else 2577 return 32; 2578 end if; 2579 end Type_Size; 2580 2581 ----------- 2582 -- Value -- 2583 ----------- 2584 2585 function Value 2586 (Name : Table_Name; 2587 J : Natural; 2588 K : Natural := 0) return Natural 2589 is 2590 begin 2591 case Name is 2592 when Character_Position => 2593 return Get_Char_Pos (J); 2594 2595 when Used_Character_Set => 2596 return Get_Used_Char (Character'Val (J)); 2597 2598 when Function_Table_1 => 2599 return Get_Table (T1, J, K); 2600 2601 when Function_Table_2 => 2602 return Get_Table (T2, J, K); 2603 2604 when Graph_Table => 2605 return Get_Graph (J); 2606 end case; 2607 end Value; 2608 2609end GNAT.Perfect_Hash_Generators; 2610