1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- G N A T . S P I T B O L --
9 -- Copyright (C) 1998-2005 Ada Core Technologies, Inc. --
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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with Ada.Strings; use Ada.Strings;
35 with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux;
37 with GNAT.Debug_Utilities; use GNAT.Debug_Utilities;
38 with GNAT.IO; use GNAT.IO;
40 with Unchecked_Deallocation;
42 package body GNAT.Spitbol is
48 function "&" (Num : Integer; Str : String) return String is
53 function "&" (Str : String; Num : Integer) return String is
58 function "&" (Num : Integer; Str : VString) return VString is
63 function "&" (Str : VString; Num : Integer) return VString is
72 function Char (Num : Natural) return Character is
74 return Character'Val (Num);
84 Pad : Character := ' ') return VString
87 if Length (Str) >= Len then
90 return Tail (Str, Len, Pad);
97 Pad : Character := ' ') return VString
100 if Str'Length >= Len then
105 R : String (1 .. Len);
108 for J in 1 .. Len - Str'Length loop
112 R (Len - Str'Length + 1 .. Len) := Str;
119 (Str : in out VString;
121 Pad : Character := ' ')
124 if Length (Str) >= Len then
127 Tail (Str, Len, Pad);
135 function N (Str : VString) return Integer is
139 Get_String (Str, S, L);
140 return Integer'Value (S (1 .. L));
147 function Reverse_String (Str : VString) return VString is
152 Get_String (Str, S, L);
155 Result : String (1 .. L);
159 Result (J) := S (L + 1 - J);
166 function Reverse_String (Str : String) return VString is
167 Result : String (1 .. Str'Length);
170 for J in 1 .. Str'Length loop
171 Result (J) := Str (Str'Last + 1 - J);
177 procedure Reverse_String (Str : in out VString) is
182 Get_String (Str, S, L);
185 Result : String (1 .. L);
189 Result (J) := S (L + 1 - J);
192 Set_String (Str, Result);
203 Pad : Character := ' ') return VString
206 if Length (Str) >= Len then
209 return Head (Str, Len, Pad);
216 Pad : Character := ' ') return VString
219 if Str'Length >= Len then
224 R : String (1 .. Len);
227 for J in Str'Length + 1 .. Len loop
231 R (1 .. Str'Length) := Str;
238 (Str : in out VString;
240 Pad : Character := ' ')
243 if Length (Str) >= Len then
247 Head (Str, Len, Pad);
255 function S (Num : Integer) return String is
256 Buf : String (1 .. 30);
257 Ptr : Natural := Buf'Last + 1;
258 Val : Natural := abs (Num);
263 Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));
273 return Buf (Ptr .. Buf'Last);
283 Len : Natural) return VString
289 Get_String (Str, S, L);
293 elsif Start + Len - 1 > L then
296 return V (S (Start .. Start + Len - 1));
303 Len : Natural) return VString
306 if Start > Str'Length then
308 elsif Start + Len > Str'Length then
312 V (Str (Str'First + Start - 1 .. Str'First + Start + Len - 2));
320 package body Table is
322 procedure Free is new
323 Unchecked_Deallocation (Hash_Element, Hash_Element_Ptr);
325 -----------------------
326 -- Local Subprograms --
327 -----------------------
329 function Hash (Str : String) return Unsigned_32;
330 -- Compute hash function for given String
336 procedure Adjust (Object : in out Table) is
337 Ptr1 : Hash_Element_Ptr;
338 Ptr2 : Hash_Element_Ptr;
341 for J in Object.Elmts'Range loop
342 Ptr1 := Object.Elmts (J)'Unrestricted_Access;
344 if Ptr1.Name /= null then
346 Ptr1.Name := new String'(Ptr1.Name.all);
347 exit when Ptr1.Next = null;
349 Ptr1.Next := new Hash_Element'(Ptr2.all);
360 procedure Clear (T : in out Table) is
361 Ptr1 : Hash_Element_Ptr;
362 Ptr2 : Hash_Element_Ptr;
365 for J in T.Elmts'Range loop
366 if T.Elmts (J).Name /= null then
367 Free (T.Elmts (J).Name);
368 T.Elmts (J).Value := Null_Value;
370 Ptr1 := T.Elmts (J).Next;
371 T.Elmts (J).Next := null;
373 while Ptr1 /= null loop
383 ----------------------
384 -- Convert_To_Array --
385 ----------------------
387 function Convert_To_Array (T : Table) return Table_Array is
388 Num_Elmts : Natural := 0;
389 Elmt : Hash_Element_Ptr;
392 for J in T.Elmts'Range loop
393 Elmt := T.Elmts (J)'Unrestricted_Access;
395 if Elmt.Name /= null then
397 Num_Elmts := Num_Elmts + 1;
399 exit when Elmt = null;
405 TA : Table_Array (1 .. Num_Elmts);
409 for J in T.Elmts'Range loop
410 Elmt := T.Elmts (J)'Unrestricted_Access;
412 if Elmt.Name /= null then
414 Set_String (TA (P).Name, Elmt.Name.all);
415 TA (P).Value := Elmt.Value;
418 exit when Elmt = null;
425 end Convert_To_Array;
431 procedure Copy (From : in Table; To : in out Table) is
432 Elmt : Hash_Element_Ptr;
437 for J in From.Elmts'Range loop
438 Elmt := From.Elmts (J)'Unrestricted_Access;
439 if Elmt.Name /= null then
441 Set (To, Elmt.Name.all, Elmt.Value);
443 exit when Elmt = null;
453 procedure Delete (T : in out Table; Name : Character) is
455 Delete (T, String'(1 => Name));
458 procedure Delete (T : in out Table; Name : VString) is
462 Get_String (Name, S, L);
463 Delete (T, S (1 .. L));
466 procedure Delete (T : in out Table; Name : String) is
467 Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
468 Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
469 Next : Hash_Element_Ptr;
472 if Elmt.Name = null then
475 elsif Elmt.Name.all = Name then
478 if Elmt.Next = null then
479 Elmt.Value := Null_Value;
484 Elmt.Name := Next.Name;
485 Elmt.Value := Next.Value;
486 Elmt.Next := Next.Next;
498 elsif Next.Name.all = Name then
500 Elmt.Next := Next.Next;
515 procedure Dump (T : Table; Str : String := "Table") is
516 Num_Elmts : Natural := 0;
517 Elmt : Hash_Element_Ptr;
520 for J in T.Elmts'Range loop
521 Elmt := T.Elmts (J)'Unrestricted_Access;
523 if Elmt.Name /= null then
525 Num_Elmts := Num_Elmts + 1;
527 (Str & '<' & Image (Elmt.Name.all) & "> = " &
530 exit when Elmt = null;
535 if Num_Elmts = 0 then
536 Put_Line (Str & " is empty");
540 procedure Dump (T : Table_Array; Str : String := "Table_Array") is
543 Put_Line (Str & " is empty");
546 for J in T'Range loop
548 (Str & '(' & Image (To_String (T (J).Name)) & ") = " &
558 procedure Finalize (Object : in out Table) is
559 Ptr1 : Hash_Element_Ptr;
560 Ptr2 : Hash_Element_Ptr;
563 for J in Object.Elmts'Range loop
564 Ptr1 := Object.Elmts (J).Next;
565 Free (Object.Elmts (J).Name);
566 while Ptr1 /= null loop
579 function Get (T : Table; Name : Character) return Value_Type is
581 return Get (T, String'(1 => Name));
584 function Get (T : Table; Name : VString) return Value_Type is
588 Get_String (Name, S, L);
589 return Get (T, S (1 .. L));
592 function Get (T : Table; Name : String) return Value_Type is
593 Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
594 Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
597 if Elmt.Name = null then
602 if Name = Elmt.Name.all then
620 function Hash (Str : String) return Unsigned_32 is
621 Result : Unsigned_32 := Str'Length;
624 for J in Str'Range loop
625 Result := Rotate_Left (Result, 1) +
626 Unsigned_32 (Character'Pos (Str (J)));
636 function Present (T : Table; Name : Character) return Boolean is
638 return Present (T, String'(1 => Name));
641 function Present (T : Table; Name : VString) return Boolean is
645 Get_String (Name, S, L);
646 return Present (T, S (1 .. L));
649 function Present (T : Table; Name : String) return Boolean is
650 Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
651 Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
654 if Elmt.Name = null then
659 if Name = Elmt.Name.all then
677 procedure Set (T : in out Table; Name : VString; Value : Value_Type) is
681 Get_String (Name, S, L);
682 Set (T, S (1 .. L), Value);
685 procedure Set (T : in out Table; Name : Character; Value : Value_Type) is
687 Set (T, String'(1 => Name), Value);
696 if Value = Null_Value then
701 Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
702 Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
704 subtype String1 is String (1 .. Name'Length);
707 if Elmt.Name = null then
708 Elmt.Name := new String'(String1 (Name));
714 if Name = Elmt.Name.all then
718 elsif Elmt.Next = null then
719 Elmt.Next := new Hash_Element'(
720 Name => new String'(String1 (Name)),
739 function Trim (Str : VString) return VString is
741 return Trim (Str, Right);
744 function Trim (Str : String) return VString is
746 for J in reverse Str'Range loop
747 if Str (J) /= ' ' then
748 return V (Str (Str'First .. J));
755 procedure Trim (Str : in out VString) is
764 function V (Num : Integer) return VString is
765 Buf : String (1 .. 30);
766 Ptr : Natural := Buf'Last + 1;
767 Val : Natural := abs (Num);
772 Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));
782 return V (Buf (Ptr .. Buf'Last));