1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- G N A T . S P I T B O L --
9 -- Copyright (C) 1998-2002 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
31 ------------------------------------------------------------------------------
33 with Ada
.Strings
; use Ada
.Strings
;
34 with Ada
.Strings
.Unbounded
.Aux
; use Ada
.Strings
.Unbounded
.Aux
;
36 with GNAT
.Debug_Utilities
; use GNAT
.Debug_Utilities
;
37 with GNAT
.IO
; use GNAT
.IO
;
39 with Unchecked_Deallocation
;
41 package body GNAT
.Spitbol
is
47 function "&" (Num
: Integer; Str
: String) return String is
52 function "&" (Str
: String; Num
: Integer) return String is
57 function "&" (Num
: Integer; Str
: VString
) return VString
is
62 function "&" (Str
: VString
; Num
: Integer) return VString
is
71 function Char
(Num
: Natural) return Character is
73 return Character'Val (Num
);
83 Pad
: Character := ' ')
87 if Length
(Str
) >= Len
then
90 return Tail
(Str
, Len
, Pad
);
97 Pad
: Character := ' ')
101 if Str
'Length >= Len
then
106 R
: String (1 .. Len
);
109 for J
in 1 .. Len
- Str
'Length loop
113 R
(Len
- Str
'Length + 1 .. Len
) := Str
;
120 (Str
: in out VString
;
122 Pad
: Character := ' ')
125 if Length
(Str
) >= Len
then
128 Tail
(Str
, Len
, Pad
);
136 function N
(Str
: VString
) return Integer is
138 return Integer'Value (Get_String
(Str
).all);
145 function Reverse_String
(Str
: VString
) return VString
is
146 Len
: constant Natural := Length
(Str
);
147 Chars
: constant String_Access
:= Get_String
(Str
);
148 Result
: String (1 .. Len
);
151 for J
in 1 .. Len
loop
152 Result
(J
) := Chars
(Len
+ 1 - J
);
158 function Reverse_String
(Str
: String) return VString
is
159 Result
: String (1 .. Str
'Length);
162 for J
in 1 .. Str
'Length loop
163 Result
(J
) := Str
(Str
'Last + 1 - J
);
169 procedure Reverse_String
(Str
: in out VString
) is
170 Len
: constant Natural := Length
(Str
);
171 Chars
: String_Access
:= Get_String
(Str
);
175 for J
in 1 .. Len
/ 2 loop
177 Chars
(J
) := Chars
(Len
+ 1 - J
);
178 Chars
(Len
+ 1 - J
) := Temp
;
189 Pad
: Character := ' ')
193 if Length
(Str
) >= Len
then
196 return Head
(Str
, Len
, Pad
);
203 Pad
: Character := ' ')
207 if Str
'Length >= Len
then
212 R
: String (1 .. Len
);
215 for J
in Str
'Length + 1 .. Len
loop
219 R
(1 .. Str
'Length) := Str
;
226 (Str
: in out VString
;
228 Pad
: Character := ' ')
231 if Length
(Str
) >= Len
then
235 Head
(Str
, Len
, Pad
);
243 function S
(Num
: Integer) return String is
244 Buf
: String (1 .. 30);
245 Ptr
: Natural := Buf
'Last + 1;
246 Val
: Natural := abs (Num
);
251 Buf
(Ptr
) := Character'Val (Val
mod 10 + Character'Pos ('0'));
261 return Buf
(Ptr
.. Buf
'Last);
275 if Start
> Length
(Str
) then
278 elsif Start
+ Len
- 1 > Length
(Str
) then
282 return V
(Get_String
(Str
).all (Start
.. Start
+ Len
- 1));
293 if Start
> Str
'Length then
296 elsif Start
+ Len
> Str
'Length then
301 V
(Str
(Str
'First + Start
- 1 .. Str
'First + Start
+ Len
- 2));
309 package body Table
is
311 procedure Free
is new
312 Unchecked_Deallocation
(Hash_Element
, Hash_Element_Ptr
);
314 -----------------------
315 -- Local Subprograms --
316 -----------------------
318 function Hash
(Str
: String) return Unsigned_32
;
319 -- Compute hash function for given String
325 procedure Adjust
(Object
: in out Table
) is
326 Ptr1
: Hash_Element_Ptr
;
327 Ptr2
: Hash_Element_Ptr
;
330 for J
in Object
.Elmts
'Range loop
331 Ptr1
:= Object
.Elmts
(J
)'Unrestricted_Access;
333 if Ptr1
.Name
/= null then
335 Ptr1
.Name
:= new String'(Ptr1.Name.all);
336 exit when Ptr1.Next = null;
338 Ptr1.Next := new Hash_Element'(Ptr2
.all);
349 procedure Clear
(T
: in out Table
) is
350 Ptr1
: Hash_Element_Ptr
;
351 Ptr2
: Hash_Element_Ptr
;
354 for J
in T
.Elmts
'Range loop
355 if T
.Elmts
(J
).Name
/= null then
356 Free
(T
.Elmts
(J
).Name
);
357 T
.Elmts
(J
).Value
:= Null_Value
;
359 Ptr1
:= T
.Elmts
(J
).Next
;
360 T
.Elmts
(J
).Next
:= null;
362 while Ptr1
/= null loop
372 ----------------------
373 -- Convert_To_Array --
374 ----------------------
376 function Convert_To_Array
(T
: Table
) return Table_Array
is
377 Num_Elmts
: Natural := 0;
378 Elmt
: Hash_Element_Ptr
;
381 for J
in T
.Elmts
'Range loop
382 Elmt
:= T
.Elmts
(J
)'Unrestricted_Access;
384 if Elmt
.Name
/= null then
386 Num_Elmts
:= Num_Elmts
+ 1;
388 exit when Elmt
= null;
394 TA
: Table_Array
(1 .. Num_Elmts
);
398 for J
in T
.Elmts
'Range loop
399 Elmt
:= T
.Elmts
(J
)'Unrestricted_Access;
401 if Elmt
.Name
/= null then
403 Set_String
(TA
(P
).Name
, Elmt
.Name
.all);
404 TA
(P
).Value
:= Elmt
.Value
;
407 exit when Elmt
= null;
414 end Convert_To_Array
;
420 procedure Copy
(From
: in Table
; To
: in out Table
) is
421 Elmt
: Hash_Element_Ptr
;
426 for J
in From
.Elmts
'Range loop
427 Elmt
:= From
.Elmts
(J
)'Unrestricted_Access;
428 if Elmt
.Name
/= null then
430 Set
(To
, Elmt
.Name
.all, Elmt
.Value
);
432 exit when Elmt
= null;
442 procedure Delete
(T
: in out Table
; Name
: Character) is
444 Delete
(T
, String'(1 => Name));
447 procedure Delete (T : in out Table; Name : VString) is
449 Delete (T, Get_String (Name).all);
452 procedure Delete (T : in out Table; Name : String) is
453 Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
454 Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
455 Next : Hash_Element_Ptr;
458 if Elmt.Name = null then
461 elsif Elmt.Name.all = Name then
464 if Elmt.Next = null then
465 Elmt.Value := Null_Value;
470 Elmt.Name := Next.Name;
471 Elmt.Value := Next.Value;
472 Elmt.Next := Next.Next;
484 elsif Next.Name.all = Name then
486 Elmt.Next := Next.Next;
501 procedure Dump (T : Table; Str : String := "Table") is
502 Num_Elmts : Natural := 0;
503 Elmt : Hash_Element_Ptr;
506 for J in T.Elmts'Range loop
507 Elmt := T.Elmts (J)'Unrestricted_Access;
509 if Elmt.Name /= null then
511 Num_Elmts := Num_Elmts + 1;
513 (Str & '<' & Image (Elmt.Name.all) & "> = " &
516 exit when Elmt = null;
521 if Num_Elmts = 0 then
522 Put_Line (Str & " is empty");
526 procedure Dump (T : Table_Array; Str : String := "Table_Array") is
529 Put_Line (Str & " is empty");
532 for J in T'Range loop
534 (Str & '(' & Image (To_String (T (J).Name)) & ") = " &
544 procedure Finalize (Object : in out Table) is
545 Ptr1 : Hash_Element_Ptr;
546 Ptr2 : Hash_Element_Ptr;
549 for J in Object.Elmts'Range loop
550 Ptr1 := Object.Elmts (J).Next;
551 Free (Object.Elmts (J).Name);
552 while Ptr1 /= null loop
565 function Get (T : Table; Name : Character) return Value_Type is
567 return Get (T, String'(1 => Name
));
570 function Get
(T
: Table
; Name
: VString
) return Value_Type
is
572 return Get
(T
, Get_String
(Name
).all);
575 function Get
(T
: Table
; Name
: String) return Value_Type
is
576 Slot
: constant Unsigned_32
:= Hash
(Name
) mod T
.N
+ 1;
577 Elmt
: Hash_Element_Ptr
:= T
.Elmts
(Slot
)'Unrestricted_Access;
580 if Elmt
.Name
= null then
585 if Name
= Elmt
.Name
.all then
603 function Hash
(Str
: String) return Unsigned_32
is
604 Result
: Unsigned_32
:= Str
'Length;
607 for J
in Str
'Range loop
608 Result
:= Rotate_Left
(Result
, 1) +
609 Unsigned_32
(Character'Pos (Str
(J
)));
619 function Present
(T
: Table
; Name
: Character) return Boolean is
621 return Present
(T
, String'(1 => Name));
624 function Present (T : Table; Name : VString) return Boolean is
626 return Present (T, Get_String (Name).all);
629 function Present (T : Table; Name : String) return Boolean is
630 Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
631 Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
634 if Elmt.Name = null then
639 if Name = Elmt.Name.all then
657 procedure Set (T : in out Table; Name : VString; Value : Value_Type) is
659 Set (T, Get_String (Name).all, Value);
662 procedure Set (T : in out Table; Name : Character; Value : Value_Type) is
664 Set (T, String'(1 => Name
), Value
);
673 if Value
= Null_Value
then
678 Slot
: constant Unsigned_32
:= Hash
(Name
) mod T
.N
+ 1;
679 Elmt
: Hash_Element_Ptr
:= T
.Elmts
(Slot
)'Unrestricted_Access;
681 subtype String1
is String (1 .. Name
'Length);
684 if Elmt
.Name
= null then
685 Elmt
.Name
:= new String'(String1 (Name));
691 if Name = Elmt.Name.all then
695 elsif Elmt.Next = null then
696 Elmt.Next := new Hash_Element'(
697 Name
=> new String'(String1 (Name)),
716 function Trim (Str : VString) return VString is
718 return Trim (Str, Right);
721 function Trim (Str : String) return VString is
723 for J in reverse Str'Range loop
724 if Str (J) /= ' ' then
725 return V (Str (Str'First .. J));
732 procedure Trim (Str : in out VString) is
741 function V (Num : Integer) return VString is
742 Buf : String (1 .. 30);
743 Ptr : Natural := Buf'Last + 1;
744 Val : Natural := abs (Num);
749 Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));
759 return V (Buf (Ptr .. Buf'Last));