1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- G N A T . S P I T B O L --
9 -- $Revision: 1.15 $ --
11 -- Copyright (C) 1998 Ada Core Technologies, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
35 with Ada.Strings; use Ada.Strings;
36 with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux;
38 with GNAT.Debug_Utilities; use GNAT.Debug_Utilities;
39 with GNAT.IO; use GNAT.IO;
41 with Unchecked_Deallocation;
43 package body GNAT.Spitbol is
49 function "&" (Num : Integer; Str : String) return String is
54 function "&" (Str : String; Num : Integer) return String is
59 function "&" (Num : Integer; Str : VString) return VString is
64 function "&" (Str : VString; Num : Integer) return VString is
73 function Char (Num : Natural) return Character is
75 return Character'Val (Num);
85 Pad : Character := ' ')
89 if Length (Str) >= Len then
92 return Tail (Str, Len, Pad);
99 Pad : Character := ' ')
103 if Str'Length >= Len then
108 R : String (1 .. Len);
111 for J in 1 .. Len - Str'Length loop
115 R (Len - Str'Length + 1 .. Len) := Str;
122 (Str : in out VString;
124 Pad : Character := ' ')
127 if Length (Str) >= Len then
130 Tail (Str, Len, Pad);
138 function N (Str : VString) return Integer is
140 return Integer'Value (Get_String (Str).all);
147 function Reverse_String (Str : VString) return VString is
148 Len : constant Natural := Length (Str);
149 Result : String (1 .. Len);
150 Chars : String_Access := Get_String (Str);
153 for J in 1 .. Len loop
154 Result (J) := Chars (Len + 1 - J);
160 function Reverse_String (Str : String) return VString is
161 Result : String (1 .. Str'Length);
164 for J in 1 .. Str'Length loop
165 Result (J) := Str (Str'Last + 1 - J);
171 procedure Reverse_String (Str : in out VString) is
172 Len : constant Natural := Length (Str);
173 Chars : String_Access := Get_String (Str);
177 for J in 1 .. Len / 2 loop
179 Chars (J) := Chars (Len + 1 - J);
180 Chars (Len + 1 - J) := Temp;
191 Pad : Character := ' ')
195 if Length (Str) >= Len then
198 return Head (Str, Len, Pad);
205 Pad : Character := ' ')
209 if Str'Length >= Len then
214 R : String (1 .. Len);
217 for J in Str'Length + 1 .. Len loop
221 R (1 .. Str'Length) := Str;
228 (Str : in out VString;
230 Pad : Character := ' ')
233 if Length (Str) >= Len then
237 Head (Str, Len, Pad);
245 function S (Num : Integer) return String is
246 Buf : String (1 .. 30);
247 Ptr : Natural := Buf'Last + 1;
248 Val : Natural := abs (Num);
253 Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));
263 return Buf (Ptr .. Buf'Last);
277 if Start > Length (Str) then
280 elsif Start + Len - 1 > Length (Str) then
284 return V (Get_String (Str).all (Start .. Start + Len - 1));
295 if Start > Str'Length then
298 elsif Start + Len > Str'Length then
303 V (Str (Str'First + Start - 1 .. Str'First + Start + Len - 2));
311 package body Table is
313 procedure Free is new
314 Unchecked_Deallocation (Hash_Element, Hash_Element_Ptr);
316 -----------------------
317 -- Local Subprograms --
318 -----------------------
320 function Hash (Str : String) return Unsigned_32;
321 -- Compute hash function for given String
327 procedure Adjust (Object : in out Table) is
328 Ptr1 : Hash_Element_Ptr;
329 Ptr2 : Hash_Element_Ptr;
332 for J in Object.Elmts'Range loop
333 Ptr1 := Object.Elmts (J)'Unrestricted_Access;
335 if Ptr1.Name /= null then
337 Ptr1.Name := new String'(Ptr1.Name.all);
338 exit when Ptr1.Next = null;
340 Ptr1.Next := new Hash_Element'(Ptr2.all);
351 procedure Clear (T : in out Table) is
352 Ptr1 : Hash_Element_Ptr;
353 Ptr2 : Hash_Element_Ptr;
356 for J in T.Elmts'Range loop
357 if T.Elmts (J).Name /= null then
358 Free (T.Elmts (J).Name);
359 T.Elmts (J).Value := Null_Value;
361 Ptr1 := T.Elmts (J).Next;
362 T.Elmts (J).Next := null;
364 while Ptr1 /= null loop
374 ----------------------
375 -- Convert_To_Array --
376 ----------------------
378 function Convert_To_Array (T : Table) return Table_Array is
379 Num_Elmts : Natural := 0;
380 Elmt : Hash_Element_Ptr;
383 for J in T.Elmts'Range loop
384 Elmt := T.Elmts (J)'Unrestricted_Access;
386 if Elmt.Name /= null then
388 Num_Elmts := Num_Elmts + 1;
390 exit when Elmt = null;
396 TA : Table_Array (1 .. Num_Elmts);
400 for J in T.Elmts'Range loop
401 Elmt := T.Elmts (J)'Unrestricted_Access;
403 if Elmt.Name /= null then
405 Set_String (TA (P).Name, Elmt.Name.all);
406 TA (P).Value := Elmt.Value;
409 exit when Elmt = null;
416 end Convert_To_Array;
422 procedure Copy (From : in Table; To : in out Table) is
423 Elmt : Hash_Element_Ptr;
428 for J in From.Elmts'Range loop
429 Elmt := From.Elmts (J)'Unrestricted_Access;
430 if Elmt.Name /= null then
432 Set (To, Elmt.Name.all, Elmt.Value);
434 exit when Elmt = null;
444 procedure Delete (T : in out Table; Name : Character) is
446 Delete (T, String'(1 => Name));
449 procedure Delete (T : in out Table; Name : VString) is
451 Delete (T, Get_String (Name).all);
454 procedure Delete (T : in out Table; Name : String) is
455 Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
456 Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
457 Next : Hash_Element_Ptr;
460 if Elmt.Name = null then
463 elsif Elmt.Name.all = Name then
466 if Elmt.Next = null then
467 Elmt.Value := Null_Value;
472 Elmt.Name := Next.Name;
473 Elmt.Value := Next.Value;
474 Elmt.Next := Next.Next;
486 elsif Next.Name.all = Name then
488 Elmt.Next := Next.Next;
503 procedure Dump (T : Table; Str : String := "Table") is
504 Num_Elmts : Natural := 0;
505 Elmt : Hash_Element_Ptr;
508 for J in T.Elmts'Range loop
509 Elmt := T.Elmts (J)'Unrestricted_Access;
511 if Elmt.Name /= null then
513 Num_Elmts := Num_Elmts + 1;
515 (Str & '<' & Image (Elmt.Name.all) & "> = " &
518 exit when Elmt = null;
523 if Num_Elmts = 0 then
524 Put_Line (Str & " is empty");
528 procedure Dump (T : Table_Array; Str : String := "Table_Array") is
531 Put_Line (Str & " is empty");
534 for J in T'Range loop
536 (Str & '(' & Image (To_String (T (J).Name)) & ") = " &
546 procedure Finalize (Object : in out Table) is
547 Ptr1 : Hash_Element_Ptr;
548 Ptr2 : Hash_Element_Ptr;
551 for J in Object.Elmts'Range loop
552 Ptr1 := Object.Elmts (J).Next;
553 Free (Object.Elmts (J).Name);
554 while Ptr1 /= null loop
567 function Get (T : Table; Name : Character) return Value_Type is
569 return Get (T, String'(1 => Name));
572 function Get (T : Table; Name : VString) return Value_Type is
574 return Get (T, Get_String (Name).all);
577 function Get (T : Table; Name : String) return Value_Type is
578 Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
579 Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
582 if Elmt.Name = null then
587 if Name = Elmt.Name.all then
605 function Hash (Str : String) return Unsigned_32 is
606 Result : Unsigned_32 := Str'Length;
609 for J in Str'Range loop
610 Result := Rotate_Left (Result, 1) +
611 Unsigned_32 (Character'Pos (Str (J)));
621 function Present (T : Table; Name : Character) return Boolean is
623 return Present (T, String'(1 => Name));
626 function Present (T : Table; Name : VString) return Boolean is
628 return Present (T, Get_String (Name).all);
631 function Present (T : Table; Name : String) return Boolean is
632 Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
633 Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
636 if Elmt.Name = null then
641 if Name = Elmt.Name.all then
659 procedure Set (T : in out Table; Name : VString; Value : Value_Type) is
661 Set (T, Get_String (Name).all, Value);
664 procedure Set (T : in out Table; Name : Character; Value : Value_Type) is
666 Set (T, String'(1 => Name), Value);
675 if Value = Null_Value then
680 Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
681 Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
683 subtype String1 is String (1 .. Name'Length);
686 if Elmt.Name = null then
687 Elmt.Name := new String'(String1 (Name));
693 if Name = Elmt.Name.all then
697 elsif Elmt.Next = null then
698 Elmt.Next := new Hash_Element'(
699 Name => new String'(String1 (Name)),
718 function Trim (Str : VString) return VString is
720 return Trim (Str, Right);
723 function Trim (Str : String) return VString is
725 for J in reverse Str'Range loop
726 if Str (J) /= ' ' then
727 return V (Str (Str'First .. J));
734 procedure Trim (Str : in out VString) is
743 function V (Num : Integer) return VString is
744 Buf : String (1 .. 30);
745 Ptr : Natural := Buf'Last + 1;
746 Val : Natural := abs (Num);
751 Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));
761 return V (Buf (Ptr .. Buf'Last));