770 lines
19 KiB
Ada
770 lines
19 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT LIBRARY COMPONENTS --
|
|
-- --
|
|
-- G N A T . S P I T B O L --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1998-2012, AdaCore --
|
|
-- --
|
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
|
-- --
|
|
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
-- additional permissions described in the GCC Runtime Library Exception, --
|
|
-- version 3.1, as published by the Free Software Foundation. --
|
|
-- --
|
|
-- You should have received a copy of the GNU General Public License and --
|
|
-- a copy of the GCC Runtime Library Exception along with this program; --
|
|
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
-- <http://www.gnu.org/licenses/>. --
|
|
-- --
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
with Ada.Strings; use Ada.Strings;
|
|
with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux;
|
|
|
|
with GNAT.Debug_Utilities; use GNAT.Debug_Utilities;
|
|
with GNAT.IO; use GNAT.IO;
|
|
|
|
with System.String_Hash;
|
|
|
|
with Ada.Unchecked_Deallocation;
|
|
|
|
package body GNAT.Spitbol is
|
|
|
|
---------
|
|
-- "&" --
|
|
---------
|
|
|
|
function "&" (Num : Integer; Str : String) return String is
|
|
begin
|
|
return S (Num) & Str;
|
|
end "&";
|
|
|
|
function "&" (Str : String; Num : Integer) return String is
|
|
begin
|
|
return Str & S (Num);
|
|
end "&";
|
|
|
|
function "&" (Num : Integer; Str : VString) return VString is
|
|
begin
|
|
return S (Num) & Str;
|
|
end "&";
|
|
|
|
function "&" (Str : VString; Num : Integer) return VString is
|
|
begin
|
|
return Str & S (Num);
|
|
end "&";
|
|
|
|
----------
|
|
-- Char --
|
|
----------
|
|
|
|
function Char (Num : Natural) return Character is
|
|
begin
|
|
return Character'Val (Num);
|
|
end Char;
|
|
|
|
----------
|
|
-- Lpad --
|
|
----------
|
|
|
|
function Lpad
|
|
(Str : VString;
|
|
Len : Natural;
|
|
Pad : Character := ' ') return VString
|
|
is
|
|
begin
|
|
if Length (Str) >= Len then
|
|
return Str;
|
|
else
|
|
return Tail (Str, Len, Pad);
|
|
end if;
|
|
end Lpad;
|
|
|
|
function Lpad
|
|
(Str : String;
|
|
Len : Natural;
|
|
Pad : Character := ' ') return VString
|
|
is
|
|
begin
|
|
if Str'Length >= Len then
|
|
return V (Str);
|
|
|
|
else
|
|
declare
|
|
R : String (1 .. Len);
|
|
|
|
begin
|
|
for J in 1 .. Len - Str'Length loop
|
|
R (J) := Pad;
|
|
end loop;
|
|
|
|
R (Len - Str'Length + 1 .. Len) := Str;
|
|
return V (R);
|
|
end;
|
|
end if;
|
|
end Lpad;
|
|
|
|
procedure Lpad
|
|
(Str : in out VString;
|
|
Len : Natural;
|
|
Pad : Character := ' ')
|
|
is
|
|
begin
|
|
if Length (Str) >= Len then
|
|
return;
|
|
else
|
|
Tail (Str, Len, Pad);
|
|
end if;
|
|
end Lpad;
|
|
|
|
-------
|
|
-- N --
|
|
-------
|
|
|
|
function N (Str : VString) return Integer is
|
|
S : Big_String_Access;
|
|
L : Natural;
|
|
begin
|
|
Get_String (Str, S, L);
|
|
return Integer'Value (S (1 .. L));
|
|
end N;
|
|
|
|
--------------------
|
|
-- Reverse_String --
|
|
--------------------
|
|
|
|
function Reverse_String (Str : VString) return VString is
|
|
S : Big_String_Access;
|
|
L : Natural;
|
|
|
|
begin
|
|
Get_String (Str, S, L);
|
|
|
|
declare
|
|
Result : String (1 .. L);
|
|
|
|
begin
|
|
for J in 1 .. L loop
|
|
Result (J) := S (L + 1 - J);
|
|
end loop;
|
|
|
|
return V (Result);
|
|
end;
|
|
end Reverse_String;
|
|
|
|
function Reverse_String (Str : String) return VString is
|
|
Result : String (1 .. Str'Length);
|
|
|
|
begin
|
|
for J in 1 .. Str'Length loop
|
|
Result (J) := Str (Str'Last + 1 - J);
|
|
end loop;
|
|
|
|
return V (Result);
|
|
end Reverse_String;
|
|
|
|
procedure Reverse_String (Str : in out VString) is
|
|
S : Big_String_Access;
|
|
L : Natural;
|
|
|
|
begin
|
|
Get_String (Str, S, L);
|
|
|
|
declare
|
|
Result : String (1 .. L);
|
|
|
|
begin
|
|
for J in 1 .. L loop
|
|
Result (J) := S (L + 1 - J);
|
|
end loop;
|
|
|
|
Set_Unbounded_String (Str, Result);
|
|
end;
|
|
end Reverse_String;
|
|
|
|
----------
|
|
-- Rpad --
|
|
----------
|
|
|
|
function Rpad
|
|
(Str : VString;
|
|
Len : Natural;
|
|
Pad : Character := ' ') return VString
|
|
is
|
|
begin
|
|
if Length (Str) >= Len then
|
|
return Str;
|
|
else
|
|
return Head (Str, Len, Pad);
|
|
end if;
|
|
end Rpad;
|
|
|
|
function Rpad
|
|
(Str : String;
|
|
Len : Natural;
|
|
Pad : Character := ' ') return VString
|
|
is
|
|
begin
|
|
if Str'Length >= Len then
|
|
return V (Str);
|
|
|
|
else
|
|
declare
|
|
R : String (1 .. Len);
|
|
|
|
begin
|
|
for J in Str'Length + 1 .. Len loop
|
|
R (J) := Pad;
|
|
end loop;
|
|
|
|
R (1 .. Str'Length) := Str;
|
|
return V (R);
|
|
end;
|
|
end if;
|
|
end Rpad;
|
|
|
|
procedure Rpad
|
|
(Str : in out VString;
|
|
Len : Natural;
|
|
Pad : Character := ' ')
|
|
is
|
|
begin
|
|
if Length (Str) >= Len then
|
|
return;
|
|
|
|
else
|
|
Head (Str, Len, Pad);
|
|
end if;
|
|
end Rpad;
|
|
|
|
-------
|
|
-- S --
|
|
-------
|
|
|
|
function S (Num : Integer) return String is
|
|
Buf : String (1 .. 30);
|
|
Ptr : Natural := Buf'Last + 1;
|
|
Val : Natural := abs (Num);
|
|
|
|
begin
|
|
loop
|
|
Ptr := Ptr - 1;
|
|
Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));
|
|
Val := Val / 10;
|
|
exit when Val = 0;
|
|
end loop;
|
|
|
|
if Num < 0 then
|
|
Ptr := Ptr - 1;
|
|
Buf (Ptr) := '-';
|
|
end if;
|
|
|
|
return Buf (Ptr .. Buf'Last);
|
|
end S;
|
|
|
|
------------
|
|
-- Substr --
|
|
------------
|
|
|
|
function Substr
|
|
(Str : VString;
|
|
Start : Positive;
|
|
Len : Natural) return VString
|
|
is
|
|
S : Big_String_Access;
|
|
L : Natural;
|
|
|
|
begin
|
|
Get_String (Str, S, L);
|
|
|
|
if Start > L then
|
|
raise Index_Error;
|
|
elsif Start + Len - 1 > L then
|
|
raise Length_Error;
|
|
else
|
|
return V (S (Start .. Start + Len - 1));
|
|
end if;
|
|
end Substr;
|
|
|
|
function Substr
|
|
(Str : String;
|
|
Start : Positive;
|
|
Len : Natural) return VString
|
|
is
|
|
begin
|
|
if Start > Str'Length then
|
|
raise Index_Error;
|
|
elsif Start + Len - 1 > Str'Length then
|
|
raise Length_Error;
|
|
else
|
|
return
|
|
V (Str (Str'First + Start - 1 .. Str'First + Start + Len - 2));
|
|
end if;
|
|
end Substr;
|
|
|
|
-----------
|
|
-- Table --
|
|
-----------
|
|
|
|
package body Table is
|
|
|
|
procedure Free is new
|
|
Ada.Unchecked_Deallocation (Hash_Element, Hash_Element_Ptr);
|
|
|
|
-----------------------
|
|
-- Local Subprograms --
|
|
-----------------------
|
|
|
|
function Hash is new System.String_Hash.Hash
|
|
(Character, String, Unsigned_32);
|
|
|
|
------------
|
|
-- Adjust --
|
|
------------
|
|
|
|
procedure Adjust (Object : in out Table) is
|
|
Ptr1 : Hash_Element_Ptr;
|
|
Ptr2 : Hash_Element_Ptr;
|
|
|
|
begin
|
|
for J in Object.Elmts'Range loop
|
|
Ptr1 := Object.Elmts (J)'Unrestricted_Access;
|
|
|
|
if Ptr1.Name /= null then
|
|
loop
|
|
Ptr1.Name := new String'(Ptr1.Name.all);
|
|
exit when Ptr1.Next = null;
|
|
Ptr2 := Ptr1.Next;
|
|
Ptr1.Next := new Hash_Element'(Ptr2.all);
|
|
Ptr1 := Ptr1.Next;
|
|
end loop;
|
|
end if;
|
|
end loop;
|
|
end Adjust;
|
|
|
|
-----------
|
|
-- Clear --
|
|
-----------
|
|
|
|
procedure Clear (T : in out Table) is
|
|
Ptr1 : Hash_Element_Ptr;
|
|
Ptr2 : Hash_Element_Ptr;
|
|
|
|
begin
|
|
for J in T.Elmts'Range loop
|
|
if T.Elmts (J).Name /= null then
|
|
Free (T.Elmts (J).Name);
|
|
T.Elmts (J).Value := Null_Value;
|
|
|
|
Ptr1 := T.Elmts (J).Next;
|
|
T.Elmts (J).Next := null;
|
|
|
|
while Ptr1 /= null loop
|
|
Ptr2 := Ptr1.Next;
|
|
Free (Ptr1.Name);
|
|
Free (Ptr1);
|
|
Ptr1 := Ptr2;
|
|
end loop;
|
|
end if;
|
|
end loop;
|
|
end Clear;
|
|
|
|
----------------------
|
|
-- Convert_To_Array --
|
|
----------------------
|
|
|
|
function Convert_To_Array (T : Table) return Table_Array is
|
|
Num_Elmts : Natural := 0;
|
|
Elmt : Hash_Element_Ptr;
|
|
|
|
begin
|
|
for J in T.Elmts'Range loop
|
|
Elmt := T.Elmts (J)'Unrestricted_Access;
|
|
|
|
if Elmt.Name /= null then
|
|
loop
|
|
Num_Elmts := Num_Elmts + 1;
|
|
Elmt := Elmt.Next;
|
|
exit when Elmt = null;
|
|
end loop;
|
|
end if;
|
|
end loop;
|
|
|
|
declare
|
|
TA : Table_Array (1 .. Num_Elmts);
|
|
P : Natural := 1;
|
|
|
|
begin
|
|
for J in T.Elmts'Range loop
|
|
Elmt := T.Elmts (J)'Unrestricted_Access;
|
|
|
|
if Elmt.Name /= null then
|
|
loop
|
|
Set_Unbounded_String (TA (P).Name, Elmt.Name.all);
|
|
TA (P).Value := Elmt.Value;
|
|
P := P + 1;
|
|
Elmt := Elmt.Next;
|
|
exit when Elmt = null;
|
|
end loop;
|
|
end if;
|
|
end loop;
|
|
|
|
return TA;
|
|
end;
|
|
end Convert_To_Array;
|
|
|
|
----------
|
|
-- Copy --
|
|
----------
|
|
|
|
procedure Copy (From : Table; To : in out Table) is
|
|
Elmt : Hash_Element_Ptr;
|
|
|
|
begin
|
|
Clear (To);
|
|
|
|
for J in From.Elmts'Range loop
|
|
Elmt := From.Elmts (J)'Unrestricted_Access;
|
|
if Elmt.Name /= null then
|
|
loop
|
|
Set (To, Elmt.Name.all, Elmt.Value);
|
|
Elmt := Elmt.Next;
|
|
exit when Elmt = null;
|
|
end loop;
|
|
end if;
|
|
end loop;
|
|
end Copy;
|
|
|
|
------------
|
|
-- Delete --
|
|
------------
|
|
|
|
procedure Delete (T : in out Table; Name : Character) is
|
|
begin
|
|
Delete (T, String'(1 => Name));
|
|
end Delete;
|
|
|
|
procedure Delete (T : in out Table; Name : VString) is
|
|
S : Big_String_Access;
|
|
L : Natural;
|
|
begin
|
|
Get_String (Name, S, L);
|
|
Delete (T, S (1 .. L));
|
|
end Delete;
|
|
|
|
procedure Delete (T : in out Table; Name : String) is
|
|
Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
|
|
Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
|
|
Next : Hash_Element_Ptr;
|
|
|
|
begin
|
|
if Elmt.Name = null then
|
|
null;
|
|
|
|
elsif Elmt.Name.all = Name then
|
|
Free (Elmt.Name);
|
|
|
|
if Elmt.Next = null then
|
|
Elmt.Value := Null_Value;
|
|
return;
|
|
|
|
else
|
|
Next := Elmt.Next;
|
|
Elmt.Name := Next.Name;
|
|
Elmt.Value := Next.Value;
|
|
Elmt.Next := Next.Next;
|
|
Free (Next);
|
|
return;
|
|
end if;
|
|
|
|
else
|
|
loop
|
|
Next := Elmt.Next;
|
|
|
|
if Next = null then
|
|
return;
|
|
|
|
elsif Next.Name.all = Name then
|
|
Free (Next.Name);
|
|
Elmt.Next := Next.Next;
|
|
Free (Next);
|
|
return;
|
|
|
|
else
|
|
Elmt := Next;
|
|
end if;
|
|
end loop;
|
|
end if;
|
|
end Delete;
|
|
|
|
----------
|
|
-- Dump --
|
|
----------
|
|
|
|
procedure Dump (T : Table; Str : String := "Table") is
|
|
Num_Elmts : Natural := 0;
|
|
Elmt : Hash_Element_Ptr;
|
|
|
|
begin
|
|
for J in T.Elmts'Range loop
|
|
Elmt := T.Elmts (J)'Unrestricted_Access;
|
|
|
|
if Elmt.Name /= null then
|
|
loop
|
|
Num_Elmts := Num_Elmts + 1;
|
|
Put_Line
|
|
(Str & '<' & Image (Elmt.Name.all) & "> = " &
|
|
Img (Elmt.Value));
|
|
Elmt := Elmt.Next;
|
|
exit when Elmt = null;
|
|
end loop;
|
|
end if;
|
|
end loop;
|
|
|
|
if Num_Elmts = 0 then
|
|
Put_Line (Str & " is empty");
|
|
end if;
|
|
end Dump;
|
|
|
|
procedure Dump (T : Table_Array; Str : String := "Table_Array") is
|
|
begin
|
|
if T'Length = 0 then
|
|
Put_Line (Str & " is empty");
|
|
|
|
else
|
|
for J in T'Range loop
|
|
Put_Line
|
|
(Str & '(' & Image (To_String (T (J).Name)) & ") = " &
|
|
Img (T (J).Value));
|
|
end loop;
|
|
end if;
|
|
end Dump;
|
|
|
|
--------------
|
|
-- Finalize --
|
|
--------------
|
|
|
|
procedure Finalize (Object : in out Table) is
|
|
Ptr1 : Hash_Element_Ptr;
|
|
Ptr2 : Hash_Element_Ptr;
|
|
|
|
begin
|
|
for J in Object.Elmts'Range loop
|
|
Ptr1 := Object.Elmts (J).Next;
|
|
Free (Object.Elmts (J).Name);
|
|
while Ptr1 /= null loop
|
|
Ptr2 := Ptr1.Next;
|
|
Free (Ptr1.Name);
|
|
Free (Ptr1);
|
|
Ptr1 := Ptr2;
|
|
end loop;
|
|
end loop;
|
|
end Finalize;
|
|
|
|
---------
|
|
-- Get --
|
|
---------
|
|
|
|
function Get (T : Table; Name : Character) return Value_Type is
|
|
begin
|
|
return Get (T, String'(1 => Name));
|
|
end Get;
|
|
|
|
function Get (T : Table; Name : VString) return Value_Type is
|
|
S : Big_String_Access;
|
|
L : Natural;
|
|
begin
|
|
Get_String (Name, S, L);
|
|
return Get (T, S (1 .. L));
|
|
end Get;
|
|
|
|
function Get (T : Table; Name : String) return Value_Type is
|
|
Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
|
|
Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
|
|
|
|
begin
|
|
if Elmt.Name = null then
|
|
return Null_Value;
|
|
|
|
else
|
|
loop
|
|
if Name = Elmt.Name.all then
|
|
return Elmt.Value;
|
|
|
|
else
|
|
Elmt := Elmt.Next;
|
|
|
|
if Elmt = null then
|
|
return Null_Value;
|
|
end if;
|
|
end if;
|
|
end loop;
|
|
end if;
|
|
end Get;
|
|
|
|
-------------
|
|
-- Present --
|
|
-------------
|
|
|
|
function Present (T : Table; Name : Character) return Boolean is
|
|
begin
|
|
return Present (T, String'(1 => Name));
|
|
end Present;
|
|
|
|
function Present (T : Table; Name : VString) return Boolean is
|
|
S : Big_String_Access;
|
|
L : Natural;
|
|
begin
|
|
Get_String (Name, S, L);
|
|
return Present (T, S (1 .. L));
|
|
end Present;
|
|
|
|
function Present (T : Table; Name : String) return Boolean is
|
|
Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
|
|
Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
|
|
|
|
begin
|
|
if Elmt.Name = null then
|
|
return False;
|
|
|
|
else
|
|
loop
|
|
if Name = Elmt.Name.all then
|
|
return True;
|
|
|
|
else
|
|
Elmt := Elmt.Next;
|
|
|
|
if Elmt = null then
|
|
return False;
|
|
end if;
|
|
end if;
|
|
end loop;
|
|
end if;
|
|
end Present;
|
|
|
|
---------
|
|
-- Set --
|
|
---------
|
|
|
|
procedure Set (T : in out Table; Name : VString; Value : Value_Type) is
|
|
S : Big_String_Access;
|
|
L : Natural;
|
|
begin
|
|
Get_String (Name, S, L);
|
|
Set (T, S (1 .. L), Value);
|
|
end Set;
|
|
|
|
procedure Set (T : in out Table; Name : Character; Value : Value_Type) is
|
|
begin
|
|
Set (T, String'(1 => Name), Value);
|
|
end Set;
|
|
|
|
procedure Set
|
|
(T : in out Table;
|
|
Name : String;
|
|
Value : Value_Type)
|
|
is
|
|
begin
|
|
if Value = Null_Value then
|
|
Delete (T, Name);
|
|
|
|
else
|
|
declare
|
|
Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
|
|
Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
|
|
|
|
subtype String1 is String (1 .. Name'Length);
|
|
|
|
begin
|
|
if Elmt.Name = null then
|
|
Elmt.Name := new String'(String1 (Name));
|
|
Elmt.Value := Value;
|
|
return;
|
|
|
|
else
|
|
loop
|
|
if Name = Elmt.Name.all then
|
|
Elmt.Value := Value;
|
|
return;
|
|
|
|
elsif Elmt.Next = null then
|
|
Elmt.Next := new Hash_Element'(
|
|
Name => new String'(String1 (Name)),
|
|
Value => Value,
|
|
Next => null);
|
|
return;
|
|
|
|
else
|
|
Elmt := Elmt.Next;
|
|
end if;
|
|
end loop;
|
|
end if;
|
|
end;
|
|
end if;
|
|
end Set;
|
|
end Table;
|
|
|
|
----------
|
|
-- Trim --
|
|
----------
|
|
|
|
function Trim (Str : VString) return VString is
|
|
begin
|
|
return Trim (Str, Right);
|
|
end Trim;
|
|
|
|
function Trim (Str : String) return VString is
|
|
begin
|
|
for J in reverse Str'Range loop
|
|
if Str (J) /= ' ' then
|
|
return V (Str (Str'First .. J));
|
|
end if;
|
|
end loop;
|
|
|
|
return Nul;
|
|
end Trim;
|
|
|
|
procedure Trim (Str : in out VString) is
|
|
begin
|
|
Trim (Str, Right);
|
|
end Trim;
|
|
|
|
-------
|
|
-- V --
|
|
-------
|
|
|
|
function V (Num : Integer) return VString is
|
|
Buf : String (1 .. 30);
|
|
Ptr : Natural := Buf'Last + 1;
|
|
Val : Natural := abs (Num);
|
|
|
|
begin
|
|
loop
|
|
Ptr := Ptr - 1;
|
|
Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));
|
|
Val := Val / 10;
|
|
exit when Val = 0;
|
|
end loop;
|
|
|
|
if Num < 0 then
|
|
Ptr := Ptr - 1;
|
|
Buf (Ptr) := '-';
|
|
end if;
|
|
|
|
return V (Buf (Ptr .. Buf'Last));
|
|
end V;
|
|
|
|
end GNAT.Spitbol;
|