1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- G N A T . S P I T B O L --
9 -- Copyright (C) 1998-2009, AdaCore --
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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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 System
.String_Hash
;
42 with Ada
.Unchecked_Deallocation
;
44 package body GNAT
.Spitbol
is
50 function "&" (Num
: Integer; Str
: String) return String is
55 function "&" (Str
: String; Num
: Integer) return String is
60 function "&" (Num
: Integer; Str
: VString
) return VString
is
65 function "&" (Str
: VString
; Num
: Integer) return VString
is
74 function Char
(Num
: Natural) return Character is
76 return Character'Val (Num
);
86 Pad
: Character := ' ') return VString
89 if Length
(Str
) >= Len
then
92 return Tail
(Str
, Len
, Pad
);
99 Pad
: Character := ' ') return VString
102 if Str
'Length >= Len
then
107 R
: String (1 .. Len
);
110 for J
in 1 .. Len
- Str
'Length loop
114 R
(Len
- Str
'Length + 1 .. Len
) := Str
;
121 (Str
: in out VString
;
123 Pad
: Character := ' ')
126 if Length
(Str
) >= Len
then
129 Tail
(Str
, Len
, Pad
);
137 function N
(Str
: VString
) return Integer is
138 S
: Big_String_Access
;
141 Get_String
(Str
, S
, L
);
142 return Integer'Value (S
(1 .. L
));
149 function Reverse_String
(Str
: VString
) return VString
is
150 S
: Big_String_Access
;
154 Get_String
(Str
, S
, L
);
157 Result
: String (1 .. L
);
161 Result
(J
) := S
(L
+ 1 - J
);
168 function Reverse_String
(Str
: String) return VString
is
169 Result
: String (1 .. Str
'Length);
172 for J
in 1 .. Str
'Length loop
173 Result
(J
) := Str
(Str
'Last + 1 - J
);
179 procedure Reverse_String
(Str
: in out VString
) is
180 S
: Big_String_Access
;
184 Get_String
(Str
, S
, L
);
187 Result
: String (1 .. L
);
191 Result
(J
) := S
(L
+ 1 - J
);
194 Set_Unbounded_String
(Str
, Result
);
205 Pad
: Character := ' ') return VString
208 if Length
(Str
) >= Len
then
211 return Head
(Str
, Len
, Pad
);
218 Pad
: Character := ' ') return VString
221 if Str
'Length >= Len
then
226 R
: String (1 .. Len
);
229 for J
in Str
'Length + 1 .. Len
loop
233 R
(1 .. Str
'Length) := Str
;
240 (Str
: in out VString
;
242 Pad
: Character := ' ')
245 if Length
(Str
) >= Len
then
249 Head
(Str
, Len
, Pad
);
257 function S
(Num
: Integer) return String is
258 Buf
: String (1 .. 30);
259 Ptr
: Natural := Buf
'Last + 1;
260 Val
: Natural := abs (Num
);
265 Buf
(Ptr
) := Character'Val (Val
mod 10 + Character'Pos ('0'));
275 return Buf
(Ptr
.. Buf
'Last);
285 Len
: Natural) return VString
287 S
: Big_String_Access
;
291 Get_String
(Str
, S
, L
);
295 elsif Start
+ Len
- 1 > L
then
298 return V
(S
(Start
.. Start
+ Len
- 1));
305 Len
: Natural) return VString
308 if Start
> Str
'Length then
310 elsif Start
+ Len
> Str
'Length then
314 V
(Str
(Str
'First + Start
- 1 .. Str
'First + Start
+ Len
- 2));
322 package body Table
is
324 procedure Free
is new
325 Ada
.Unchecked_Deallocation
(Hash_Element
, Hash_Element_Ptr
);
327 -----------------------
328 -- Local Subprograms --
329 -----------------------
331 function Hash
is new System
.String_Hash
.Hash
332 (Character, String, Unsigned_32
);
338 procedure Adjust
(Object
: in out Table
) is
339 Ptr1
: Hash_Element_Ptr
;
340 Ptr2
: Hash_Element_Ptr
;
343 for J
in Object
.Elmts
'Range loop
344 Ptr1
:= Object
.Elmts
(J
)'Unrestricted_Access;
346 if Ptr1
.Name
/= null then
348 Ptr1
.Name
:= new String'(Ptr1.Name.all);
349 exit when Ptr1.Next = null;
351 Ptr1.Next := new Hash_Element'(Ptr2
.all);
362 procedure Clear
(T
: in out Table
) is
363 Ptr1
: Hash_Element_Ptr
;
364 Ptr2
: Hash_Element_Ptr
;
367 for J
in T
.Elmts
'Range loop
368 if T
.Elmts
(J
).Name
/= null then
369 Free
(T
.Elmts
(J
).Name
);
370 T
.Elmts
(J
).Value
:= Null_Value
;
372 Ptr1
:= T
.Elmts
(J
).Next
;
373 T
.Elmts
(J
).Next
:= null;
375 while Ptr1
/= null loop
385 ----------------------
386 -- Convert_To_Array --
387 ----------------------
389 function Convert_To_Array
(T
: Table
) return Table_Array
is
390 Num_Elmts
: Natural := 0;
391 Elmt
: Hash_Element_Ptr
;
394 for J
in T
.Elmts
'Range loop
395 Elmt
:= T
.Elmts
(J
)'Unrestricted_Access;
397 if Elmt
.Name
/= null then
399 Num_Elmts
:= Num_Elmts
+ 1;
401 exit when Elmt
= null;
407 TA
: Table_Array
(1 .. Num_Elmts
);
411 for J
in T
.Elmts
'Range loop
412 Elmt
:= T
.Elmts
(J
)'Unrestricted_Access;
414 if Elmt
.Name
/= null then
416 Set_Unbounded_String
(TA
(P
).Name
, Elmt
.Name
.all);
417 TA
(P
).Value
:= Elmt
.Value
;
420 exit when Elmt
= null;
427 end Convert_To_Array
;
433 procedure Copy
(From
: Table
; To
: in out Table
) is
434 Elmt
: Hash_Element_Ptr
;
439 for J
in From
.Elmts
'Range loop
440 Elmt
:= From
.Elmts
(J
)'Unrestricted_Access;
441 if Elmt
.Name
/= null then
443 Set
(To
, Elmt
.Name
.all, Elmt
.Value
);
445 exit when Elmt
= null;
455 procedure Delete
(T
: in out Table
; Name
: Character) is
457 Delete
(T
, String'(1 => Name));
460 procedure Delete (T : in out Table; Name : VString) is
461 S : Big_String_Access;
464 Get_String (Name, S, L);
465 Delete (T, S (1 .. L));
468 procedure Delete (T : in out Table; Name : String) is
469 Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
470 Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
471 Next : Hash_Element_Ptr;
474 if Elmt.Name = null then
477 elsif Elmt.Name.all = Name then
480 if Elmt.Next = null then
481 Elmt.Value := Null_Value;
486 Elmt.Name := Next.Name;
487 Elmt.Value := Next.Value;
488 Elmt.Next := Next.Next;
500 elsif Next.Name.all = Name then
502 Elmt.Next := Next.Next;
517 procedure Dump (T : Table; Str : String := "Table") is
518 Num_Elmts : Natural := 0;
519 Elmt : Hash_Element_Ptr;
522 for J in T.Elmts'Range loop
523 Elmt := T.Elmts (J)'Unrestricted_Access;
525 if Elmt.Name /= null then
527 Num_Elmts := Num_Elmts + 1;
529 (Str & '<' & Image (Elmt.Name.all) & "> = " &
532 exit when Elmt = null;
537 if Num_Elmts = 0 then
538 Put_Line (Str & " is empty");
542 procedure Dump (T : Table_Array; Str : String := "Table_Array") is
545 Put_Line (Str & " is empty");
548 for J in T'Range loop
550 (Str & '(' & Image (To_String (T (J).Name)) & ") = " &
560 procedure Finalize (Object : in out Table) is
561 Ptr1 : Hash_Element_Ptr;
562 Ptr2 : Hash_Element_Ptr;
565 for J in Object.Elmts'Range loop
566 Ptr1 := Object.Elmts (J).Next;
567 Free (Object.Elmts (J).Name);
568 while Ptr1 /= null loop
581 function Get (T : Table; Name : Character) return Value_Type is
583 return Get (T, String'(1 => Name
));
586 function Get
(T
: Table
; Name
: VString
) return Value_Type
is
587 S
: Big_String_Access
;
590 Get_String
(Name
, S
, L
);
591 return Get
(T
, S
(1 .. L
));
594 function Get
(T
: Table
; Name
: String) return Value_Type
is
595 Slot
: constant Unsigned_32
:= Hash
(Name
) mod T
.N
+ 1;
596 Elmt
: Hash_Element_Ptr
:= T
.Elmts
(Slot
)'Unrestricted_Access;
599 if Elmt
.Name
= null then
604 if Name
= Elmt
.Name
.all then
622 function Present
(T
: Table
; Name
: Character) return Boolean is
624 return Present
(T
, String'(1 => Name));
627 function Present (T : Table; Name : VString) return Boolean is
628 S : Big_String_Access;
631 Get_String (Name, S, L);
632 return Present (T, S (1 .. L));
635 function Present (T : Table; Name : String) return Boolean is
636 Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
637 Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
640 if Elmt.Name = null then
645 if Name = Elmt.Name.all then
663 procedure Set (T : in out Table; Name : VString; Value : Value_Type) is
664 S : Big_String_Access;
667 Get_String (Name, S, L);
668 Set (T, S (1 .. L), Value);
671 procedure Set (T : in out Table; Name : Character; Value : Value_Type) is
673 Set (T, String'(1 => Name
), Value
);
682 if Value
= Null_Value
then
687 Slot
: constant Unsigned_32
:= Hash
(Name
) mod T
.N
+ 1;
688 Elmt
: Hash_Element_Ptr
:= T
.Elmts
(Slot
)'Unrestricted_Access;
690 subtype String1
is String (1 .. Name
'Length);
693 if Elmt
.Name
= null then
694 Elmt
.Name
:= new String'(String1 (Name));
700 if Name = Elmt.Name.all then
704 elsif Elmt.Next = null then
705 Elmt.Next := new Hash_Element'(
706 Name
=> new String'(String1 (Name)),
725 function Trim (Str : VString) return VString is
727 return Trim (Str, Right);
730 function Trim (Str : String) return VString is
732 for J in reverse Str'Range loop
733 if Str (J) /= ' ' then
734 return V (Str (Str'First .. J));
741 procedure Trim (Str : in out VString) is
750 function V (Num : Integer) return VString is
751 Buf : String (1 .. 30);
752 Ptr : Natural := Buf'Last + 1;
753 Val : Natural := abs (Num);
758 Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));
768 return V (Buf (Ptr .. Buf'Last));